ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/IBSQLMonitor.pas
Revision: 1
Committed: Mon Jul 31 16:43:00 2000 UTC (23 years, 8 months ago) by tony
Content type: text/x-pascal
File size: 30094 byte(s)
Log Message:
Borland IBX Open Source Release

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 {************************************************************************}
28
29 unit IBSQLMonitor;
30
31 interface
32
33 uses
34 SysUtils, Windows, Messages, Classes, Forms, Controls, Dialogs, StdCtrls,
35 IB, IBUtils, IBSQL, IBCustomDataSet, IBDatabase, IBServices, IBXConst;
36
37 const
38 WM_MIN_IBSQL_MONITOR = WM_USER;
39 WM_MAX_IBSQL_MONITOR = WM_USER + 512;
40 WM_IBSQL_SQL_EVENT = WM_MIN_IBSQL_MONITOR + 1;
41
42 type
43 TIBCustomSQLMonitor = class;
44
45 { TIBSQLMonitor }
46 TSQLEvent = procedure(EventText: String; EventTime : TDateTime) of object;
47
48 TIBCustomSQLMonitor = class(TComponent)
49 private
50 FHWnd: HWND;
51 FOnSQLEvent: TSQLEvent;
52 FTraceFlags: TTraceFlags;
53 FEnabled: Boolean;
54 procedure MonitorWndProc(var Message : TMessage);
55 procedure SetEnabled(const Value: Boolean);
56 protected
57 property OnSQL: TSQLEvent read FOnSQLEvent write FOnSQLEvent;
58 property TraceFlags: TTraceFlags read FTraceFlags write FTraceFlags;
59 property Enabled : Boolean read FEnabled write SetEnabled default true;
60 public
61 constructor Create(AOwner: TComponent); override;
62 destructor Destroy; override;
63 procedure Release;
64 property Handle : HWND read FHwnd;
65 end;
66
67 TIBSQLMonitor = class(TIBCustomSQLMonitor)
68 published
69 property OnSQL;
70 property TraceFlags;
71 property Enabled;
72 end;
73
74 IIBSQLMonitorHook = interface
75 ['{CF65434C-9B75-4298-BA7E-E6B85B3C769D}']
76 procedure RegisterMonitor(SQLMonitor : TIBCustomSQLMonitor);
77 procedure UnregisterMonitor(SQLMonitor : TIBCustomSQLMonitor);
78 procedure ReleaseMonitor(Arg : TIBCustomSQLMonitor);
79 procedure SQLPrepare(qry: TIBSQL);
80 procedure SQLExecute(qry: TIBSQL);
81 procedure SQLFetch(qry: TIBSQL);
82 procedure DBConnect(db: TIBDatabase);
83 procedure DBDisconnect(db: TIBDatabase);
84 procedure TRStart(tr: TIBTransaction);
85 procedure TRCommit(tr: TIBTransaction);
86 procedure TRCommitRetaining(tr: TIBTransaction);
87 procedure TRRollback(tr: TIBTransaction);
88 procedure TRRollbackRetaining(tr: TIBTransaction);
89 procedure ServiceAttach(service: TIBCustomService);
90 procedure ServiceDetach(service: TIBCustomService);
91 procedure ServiceQuery(service: TIBCustomService);
92 procedure ServiceStart(service: TIBCustomService);
93 procedure SendMisc(Msg : String);
94 function GetTraceFlags : TTraceFlags;
95 function GetMonitorCount : Integer;
96 procedure SetTraceFlags(const Value : TTraceFlags);
97 function GetEnabled : boolean;
98 procedure SetEnabled(const Value : Boolean);
99 property TraceFlags: TTraceFlags read GetTraceFlags write SetTraceFlags;
100 property Enabled : Boolean read GetEnabled write SetEnabled;
101 end;
102
103
104 function MonitorHook: IIBSQLMonitorHook;
105 procedure EnableMonitoring;
106 procedure DisableMonitoring;
107 function MonitoringEnabled: Boolean;
108
109 implementation
110
111 uses
112 contnrs;
113
114 type
115
116 { TIBSQLMonitorHook }
117 TIBSQLMonitorHook = class(TInterfacedObject, IIBSQLMonitorHook)
118 private
119 FTraceFlags: TTraceFlags;
120 FEnabled: Boolean;
121 FEventsCreated : Boolean;
122 procedure CreateEvents;
123 protected
124 procedure WriteSQLData(Text: String; DataType: TTraceFlag);
125 public
126 constructor Create;
127 destructor Destroy; override;
128 procedure RegisterMonitor(SQLMonitor : TIBCustomSQLMonitor);
129 procedure UnregisterMonitor(SQLMonitor : TIBCustomSQLMonitor);
130 procedure ReleaseMonitor(Arg : TIBCustomSQLMonitor);
131 procedure SQLPrepare(qry: TIBSQL); virtual;
132 procedure SQLExecute(qry: TIBSQL); virtual;
133 procedure SQLFetch(qry: TIBSQL); virtual;
134 procedure DBConnect(db: TIBDatabase); virtual;
135 procedure DBDisconnect(db: TIBDatabase); virtual;
136 procedure TRStart(tr: TIBTransaction); virtual;
137 procedure TRCommit(tr: TIBTransaction); virtual;
138 procedure TRCommitRetaining(tr: TIBTransaction); virtual;
139 procedure TRRollback(tr: TIBTransaction); virtual;
140 procedure TRRollbackRetaining(tr: TIBTransaction); virtual;
141 procedure ServiceAttach(service: TIBCustomService); virtual;
142 procedure ServiceDetach(service: TIBCustomService); virtual;
143 procedure ServiceQuery(service: TIBCustomService); virtual;
144 procedure ServiceStart(service: TIBCustomService); virtual;
145 procedure SendMisc(Msg : String);
146 function GetEnabled: Boolean;
147 function GetTraceFlags: TTraceFlags;
148 function GetMonitorCount : Integer;
149 procedure SetEnabled(const Value: Boolean);
150 procedure SetTraceFlags(const Value: TTraceFlags);
151 property TraceFlags: TTraceFlags read GetTraceFlags write SetTraceFlags;
152 property Enabled : Boolean read GetEnabled write SetEnabled default true;
153 end;
154
155 { There are two possible objects. One is a trace message object.
156 This object holds the flag of the trace type plus the message.
157 The second object is a Release object. It holds the handle that
158 the CM_RELEASE message is to be queued to. }
159
160 TTraceObject = Class(TObject)
161 FDataType : TTraceFlag;
162 FMsg : String;
163 FTimeStamp : TDateTime;
164 public
165 constructor Create(Msg : String; DataType : TTraceFlag); overload;
166 constructor Create(obj : TTraceObject); overload;
167 end;
168
169 TReleaseObject = Class(TObject)
170 FHandle : THandle;
171 public
172 constructor Create(Handle : THandle);
173 end;
174
175 TWriterThread = class(TThread)
176 private
177 { Private declarations }
178 FMsgs : TObjectList;
179 procedure RemoveFromList;
180 protected
181 procedure Lock;
182 Procedure Unlock;
183 procedure BeginWrite;
184 procedure EndWrite;
185 procedure Execute; override;
186 procedure WriteToBuffer;
187 public
188 constructor Create;
189 destructor Destroy; override;
190 procedure WriteSQLData(Msg : String; DataType : TTraceFlag);
191 procedure ReleaseMonitor(HWnd : THandle);
192 end;
193
194 TReaderThread = class(TThread)
195 private
196 st : TTraceObject;
197 FMonitors : TObjectList;
198 { Private declarations }
199 protected
200 procedure BeginRead;
201 procedure EndRead;
202 procedure ReadSQLData;
203 procedure Execute; override;
204 public
205 constructor Create;
206 destructor Destroy; override;
207 procedure AddMonitor(Arg : TIBCustomSQLMonitor);
208 procedure RemoveMonitor(Arg : TIBCustomSQLMonitor);
209 end;
210
211 const
212 MonitorHookNames: array[0..5] of String = (
213 'IB.SQL.MONITOR.Mutex4_1',
214 'IB.SQL.MONITOR.SharedMem4_1',
215 'IB.SQL.MONITOR.WriteEvent4_1',
216 'IB.SQL.MONITOR.WriteFinishedEvent4_1',
217 'IB.SQL.MONITOR.ReadEvent4_1',
218 'IB.SQL.MONITOR.ReadFinishedEvent4_1'
219 );
220 cMonitorHookSize = 1024;
221 cMaxBufferSize = cMonitorHookSize - (4 * SizeOf(Integer)) - SizeOf(TDateTime);
222 cDefaultTimeout = 500; { 1 seconds }
223
224 var
225 FSharedBuffer,
226 FWriteLock,
227 FWriteEvent,
228 FWriteFinishedEvent,
229 FReadEvent,
230 FReadFinishedEvent : THandle;
231 FBuffer : PChar;
232 FMonitorCount,
233 FReaderCount,
234 FTraceDataType,
235 FBufferSize : PInteger;
236 FTimeStamp : PDateTime;
237
238 FWriterThread : TWriterThread;
239 FReaderThread : TReaderThread;
240 _MonitorHook: TIBSQLMonitorHook;
241 bDone: Boolean;
242 CS : TRTLCriticalSection;
243
244 { TIBCustomSQLMonitor }
245
246 constructor TIBCustomSQLMonitor.Create(AOwner: TComponent);
247 begin
248 inherited;
249 FTraceFlags := [tfqPrepare .. tfMisc];
250 FEnabled := true;
251 if not (csDesigning in ComponentState) then
252 begin
253 FHWnd := AllocateHWnd(MonitorWndProc);
254 MonitorHook.RegisterMonitor(self);
255 end;
256 end;
257
258 destructor TIBCustomSQLMonitor.Destroy;
259 begin
260 if not (csDesigning in ComponentState) then
261 begin
262 if FEnabled then
263 MonitorHook.UnregisterMonitor(self);
264 DeallocateHwnd(FHWnd);
265 end;
266 inherited;
267 end;
268
269 procedure TIBCustomSQLMonitor.MonitorWndProc(var Message: TMessage);
270 var
271 st : TTraceObject;
272 begin
273 case Message.Msg of
274 WM_IBSQL_SQL_EVENT:
275 begin
276 st := TTraceObject(Message.LParam);
277 if (Assigned(FOnSQLEvent)) and
278 (st.FDataType in FTraceFlags) then
279 FOnSQLEvent(st.FMsg, st.FTimeStamp);
280 st.Free;
281 end;
282 CM_RELEASE :
283 Free;
284 else
285 DefWindowProc(FHWnd, Message.Msg, Message.WParam, Message.LParam);
286 end;
287 end;
288
289 procedure TIBCustomSQLMonitor.Release;
290 begin
291 MonitorHook.ReleaseMonitor(self);
292 end;
293
294 procedure TIBCustomSQLMonitor.SetEnabled(const Value: Boolean);
295 begin
296 if Value <> FEnabled then
297 begin
298 FEnabled := Value;
299 if not (csDesigning in ComponentState) then
300 if FEnabled then
301 Monitorhook.RegisterMonitor(self)
302 else
303 MonitorHook.UnregisterMonitor(self);
304 end;
305 end;
306
307 { TIBSQLMonitorHook }
308
309 constructor TIBSQLMonitorHook.Create;
310 begin
311 inherited;
312 FEventsCreated := false;
313 end;
314
315 procedure TIBSQLMonitorHook.CreateEvents;
316 var
317 Sa : TSecurityAttributes;
318 Sd : TSecurityDescriptor;
319
320 function OpenLocalEvent(Idx: Integer): THandle;
321 begin
322 result := OpenEvent(EVENT_ALL_ACCESS, true, PChar(MonitorHookNames[Idx]));
323 if result = 0 then
324 IBError(ibxeCannotCreateSharedResource, [GetLastError]);
325 end;
326
327 function CreateLocalEvent(Idx: Integer; InitialState: Boolean): THandle;
328 begin
329 result := CreateEvent(@sa, true, InitialState, PChar(MonitorHookNames[Idx]));
330 if result = 0 then
331 IBError(ibxeCannotCreateSharedResource, [GetLastError]);
332 end;
333
334 begin
335 { Setup Secureity so anyone can connect to the MMF/Mutex/Events. This is
336 needed when IBX is used in a Service. }
337
338 InitializeSecurityDescriptor(@Sd,SECURITY_DESCRIPTOR_REVISION);
339 SetSecurityDescriptorDacl(@Sd,true,nil,false);
340 Sa.nLength := SizeOf(Sa);
341 Sa.lpSecurityDescriptor := @Sd;
342 Sa.bInheritHandle := true;
343
344 FTraceFlags := [tfQPrepare..tfMisc];
345 FEnabled := true;
346 FSharedBuffer := CreateFileMapping($FFFFFFFF, @sa, PAGE_READWRITE,
347 0, cMonitorHookSize, PChar(MonitorHookNames[1]));
348
349 if GetLastError = ERROR_ALREADY_EXISTS then
350 begin
351 FSharedBuffer := OpenFileMapping(FILE_MAP_ALL_ACCESS, false, PChar(MonitorHookNames[1]));
352 if (FSharedBuffer = 0) then
353 IBError(ibxeCannotCreateSharedResource, [GetLastError]);
354 FBuffer := MapViewOfFile(FSharedBuffer, FILE_MAP_ALL_ACCESS, 0, 0, 0);
355 if FBuffer = nil then
356 IBError(ibxeCannotCreateSharedResource, [GetLastError]);
357 FMonitorCount := PInteger(FBuffer + cMonitorHookSize - SizeOf(Integer));
358 FReaderCount := PInteger(PChar(FMonitorCount) - SizeOf(Integer));
359 FTraceDataType := PInteger(PChar(FReaderCount) - SizeOf(Integer));
360 FTimeStamp := PDateTime(PChar(FTraceDataType) - SizeOf(TDateTime));
361 FBufferSize := PInteger(PChar(FTimeStamp) - SizeOf(Integer));
362 FWriteLock := OpenMutex(MUTEX_ALL_ACCESS, False, PChar(MonitorHookNames[0]));
363 FWriteEvent := OpenLocalEvent(2);
364 FWriteFinishedEvent := OpenLocalEvent(3);
365 FReadEvent := OpenLocalEvent(4);
366 FReadFinishedEvent := OpenLocalEvent(5);
367 end
368 else
369 begin
370 FWriteLock := CreateMutex(@sa, False, PChar(MonitorHookNames[0]));
371 FWriteEvent := CreateLocalEvent(2, False);
372 FWriteFinishedEvent := CreateLocalEvent(3, True);
373 FReadEvent := CreateLocalEvent(4, False);
374 FReadFinishedEvent := CreateLocalEvent(5, False);
375
376 FBuffer := MapViewOfFile(FSharedBuffer, FILE_MAP_ALL_ACCESS, 0, 0, 0);
377 FMonitorCount := PInteger(FBuffer + cMonitorHookSize - SizeOf(Integer));
378 FReaderCount := PInteger(PChar(FMonitorCount) - SizeOf(Integer));
379 FTraceDataType := PInteger(PChar(FReaderCount) - SizeOf(Integer));
380 FTimeStamp := PDateTime(PChar(FTraceDataType) - SizeOf(TDateTime));
381 FBufferSize := PInteger(PChar(FTimeStamp) - SizeOf(Integer));
382 FMonitorCount^ := 0;
383 FReaderCount^ := 0;
384 FBufferSize^ := 0;
385 end;
386
387 { This should never evaluate to true, if it does
388 there has been a hiccup somewhere. }
389
390 if FMonitorCount^ < 0 then
391 FMonitorCount^ := 0;
392 if FReaderCount^ < 0 then
393 FReaderCount^ := 0;
394 FEventsCreated := true;
395 end;
396
397 procedure TIBSQLMonitorHook.DBConnect(db: TIBDatabase);
398 var
399 st : String;
400 begin
401 if FEnabled then
402 begin
403 if not (tfConnect in FTraceFlags * db.TraceFlags) then
404 Exit;
405 st := db.Name + ': [Connect]'; {do not localize}
406 WriteSQLData(st, tfConnect);
407 end;
408 end;
409
410 procedure TIBSQLMonitorHook.DBDisconnect(db: TIBDatabase);
411 var
412 st: String;
413 begin
414 if (Self = nil) then exit;
415 if FEnabled then
416 begin
417 if not (tfConnect in FTraceFlags * db.TraceFlags) then
418 Exit;
419 st := db.Name + ': [Disconnect]'; {do not localize}
420 WriteSQLData(st, tfConnect);
421 end;
422 end;
423
424 destructor TIBSQLMonitorHook.Destroy;
425 begin
426 if FEventsCreated then
427 begin
428 UnmapViewOfFile(FBuffer);
429 CloseHandle(FSharedBuffer);
430 CloseHandle(FWriteEvent);
431 CloseHandle(FWriteFinishedEvent);
432 CloseHandle(FReadEvent);
433 CloseHandle(FReadFinishedEvent);
434 CloseHandle(FWriteLock);
435 end;
436 inherited;
437 end;
438
439 function TIBSQLMonitorHook.GetEnabled: Boolean;
440 begin
441 Result := FEnabled;
442 end;
443
444 function TIBSQLMonitorHook.GetMonitorCount: Integer;
445 begin
446 Result := FMonitorCount^;
447 end;
448
449 function TIBSQLMonitorHook.GetTraceFlags: TTraceFlags;
450 begin
451 Result := FTraceFlags;
452 end;
453
454 procedure TIBSQLMonitorHook.RegisterMonitor(SQLMonitor: TIBCustomSQLMonitor);
455 begin
456 if not FEventsCreated then
457 CreateEvents;
458 if not Assigned(FReaderThread) then
459 FReaderThread := TReaderThread.Create;
460 FReaderThread.AddMonitor(SQLMonitor);
461 end;
462
463 procedure TIBSQLMonitorHook.ReleaseMonitor(Arg: TIBCustomSQLMonitor);
464 begin
465 FWriterThread.ReleaseMonitor(Arg.FHWnd);
466 end;
467
468 procedure TIBSQLMonitorHook.SendMisc(Msg: String);
469 begin
470 if FEnabled then
471 begin
472 WriteSQLData(Msg, tfMisc);
473 end;
474 end;
475
476 procedure TIBSQLMonitorHook.ServiceAttach(service: TIBCustomService);
477 var
478 st: String;
479 begin
480 if FEnabled then
481 begin
482 if not (tfService in (FTraceFlags * service.TraceFlags)) then
483 Exit;
484 st := service.Name + ': [Attach]'; {do not localize}
485 WriteSQLData(st, tfService);
486 end;
487 end;
488
489 procedure TIBSQLMonitorHook.ServiceDetach(service: TIBCustomService);
490 var
491 st: String;
492 begin
493 if FEnabled then
494 begin
495 if not (tfService in (FTraceFlags * service.TraceFlags)) then
496 Exit;
497 st := service.Name + ': [Detach]'; {do not localize}
498 WriteSQLData(st, tfService);
499 end;
500 end;
501
502 procedure TIBSQLMonitorHook.ServiceQuery(service: TIBCustomService);
503 var
504 st: String;
505 begin
506 if FEnabled then
507 begin
508 if not (tfService in (FTraceFlags * service.TraceFlags)) then
509 Exit;
510 st := service.Name + ': [Query]'; {do not localize}
511 WriteSQLData(st, tfService);
512 end;
513 end;
514
515 procedure TIBSQLMonitorHook.ServiceStart(service: TIBCustomService);
516 var
517 st: String;
518 begin
519 if FEnabled then
520 begin
521 if not (tfService in (FTraceFlags * service.TraceFlags)) then
522 Exit;
523 st := service.Name + ': [Start]'; {do not localize}
524 WriteSQLData(st, tfService);
525 end;
526 end;
527
528 procedure TIBSQLMonitorHook.SetEnabled(const Value: Boolean);
529 begin
530 if FEnabled <> Value then
531 FEnabled := Value;
532 if (not FEnabled) and (Assigned(FWriterThread)) then
533 begin
534 FWriterThread.Terminate;
535 FWriterThread.WaitFor;
536 FreeAndNil(FWriterThread);
537 end;
538 end;
539
540 procedure TIBSQLMonitorHook.SetTraceFlags(const Value: TTraceFlags);
541 begin
542 FTraceFlags := Value
543 end;
544
545 procedure TIBSQLMonitorHook.SQLExecute(qry: TIBSQL);
546 var
547 st: String;
548 i: Integer;
549 begin
550 if FEnabled then
551 begin
552 if not ((tfQExecute in (FTraceFlags * qry.Database.TraceFlags)) or
553 (tfStmt in (FTraceFlags * qry.Database.TraceFlags)) ) then
554 Exit;
555 if qry.Owner is TIBCustomDataSet then
556 st := TIBCustomDataSet(qry.Owner).Name
557 else
558 st := qry.Name;
559 st := st + ': [Execute] ' + qry.SQL.Text; {do not localize}
560 if qry.Params.Count > 0 then begin
561 for i := 0 to qry.Params.Count - 1 do begin
562 st := st + CRLF + ' ' + qry.Params[i].Name + ' = ';
563 try
564 if qry.Params[i].IsNull then
565 st := st + '<NULL>'; {do not localize}
566 st := st + qry.Params[i].AsString;
567 except
568 st := st + '<' + SCantPrintValue + '>';
569 end;
570 end;
571 end;
572 WriteSQLData(st, tfQExecute);
573 end;
574 end;
575
576 procedure TIBSQLMonitorHook.SQLFetch(qry: TIBSQL);
577 var
578 st: String;
579 begin
580 if FEnabled then
581 begin
582 if not ((tfQFetch in (FTraceFlags * qry.Database.TraceFlags)) or
583 (tfStmt in (FTraceFlags * qry.Database.TraceFlags))) then
584 Exit;
585 if qry.Owner is TIBCustomDataSet then
586 st := TIBCustomDataSet(qry.Owner).Name
587 else
588 st := qry.Name;
589 st := st + ': [Fetch] ' + qry.SQL.Text; {do not localize}
590 if (qry.EOF) then
591 st := st + CRLF + ' ' + SEOFReached;
592 WriteSQLData(st, tfQFetch);
593 end;
594 end;
595
596 procedure TIBSQLMonitorHook.SQLPrepare(qry: TIBSQL);
597 var
598 st: String;
599 begin
600 if FEnabled then
601 begin
602 if not ((tfQPrepare in (FTraceFlags * qry.Database.TraceFlags)) or
603 (tfStmt in (FTraceFlags * qry.Database.TraceFlags))) then
604 Exit;
605 if qry.Owner is TIBCustomDataSet then
606 st := TIBCustomDataSet(qry.Owner).Name
607 else
608 st := qry.Name;
609 st := st + ': [Prepare] ' + qry.SQL.Text + CRLF; {do not localize}
610 st := st + ' Plan: ' + qry.Plan; {do not localize}
611 WriteSQLData(st, tfQPrepare);
612 end;
613 end;
614
615 procedure TIBSQLMonitorHook.TRCommit(tr: TIBTransaction);
616 var
617 st: String;
618 begin
619 if FEnabled then
620 begin
621 if Assigned(tr.DefaultDatabase) and
622 (not (tfTransact in (FTraceFlags * tr.DefaultDatabase.TraceFlags))) then
623 Exit;
624 st := tr.Name + ': [Commit (Hard commit)]'; {do not localize}
625 WriteSQLData(st, tfTransact);
626 end;
627 end;
628
629 procedure TIBSQLMonitorHook.TRCommitRetaining(tr: TIBTransaction);
630 var
631 st: String;
632 begin
633 if FEnabled then
634 begin
635 if Assigned(tr.DefaultDatabase) and
636 (not (tfTransact in (FTraceFlags * tr.DefaultDatabase.TraceFlags))) then
637 Exit;
638 st := tr.Name + ': [Commit retaining (Soft commit)]'; {do not localize}
639 WriteSQLData(st, tfTransact);
640 end;
641 end;
642
643 procedure TIBSQLMonitorHook.TRRollback(tr: TIBTransaction);
644 var
645 st: String;
646 begin
647 if FEnabled then
648 begin
649 if Assigned(tr.DefaultDatabase) and
650 (not (tfTransact in (FTraceFlags * tr.DefaultDatabase.TraceFlags))) then
651 Exit;
652 st := tr.Name + ': [Rollback]'; {do not localize}
653 WriteSQLData(st, tfTransact);
654 end;
655 end;
656
657 procedure TIBSQLMonitorHook.TRRollbackRetaining(tr: TIBTransaction);
658 var
659 st: String;
660 begin
661 if FEnabled then
662 begin
663 if Assigned(tr.DefaultDatabase) and
664 (not (tfTransact in (FTraceFlags * tr.DefaultDatabase.TraceFlags))) then
665 Exit;
666 st := tr.Name + ': [Rollback retaining (Soft rollback)]'; {do not localize}
667 WriteSQLData(st, tfTransact);
668 end;
669 end;
670
671 procedure TIBSQLMonitorHook.TRStart(tr: TIBTransaction);
672 var
673 st: String;
674 begin
675 if FEnabled then
676 begin
677 if Assigned(tr.DefaultDatabase) and
678 (not (tfTransact in (FTraceFlags * tr.DefaultDatabase.TraceFlags))) then
679 Exit;
680 st := tr.Name + ': [Start transaction]'; {do not localize}
681 WriteSQLData(st, tfTransact);
682 end;
683 end;
684
685 procedure TIBSQLMonitorHook.UnregisterMonitor(SQLMonitor: TIBCustomSQLMonitor);
686 var
687 Created : Boolean;
688 begin
689 FReaderThread.RemoveMonitor(SQLMonitor);
690 if FReaderThread.FMonitors.Count = 0 then
691 begin
692 FReaderThread.Terminate;
693
694 { There is a possibility of a reader thread, but no writer one.
695 When in that situation, the reader needs to be released after
696 the terminate is set. To do that, create a Writer thread, send
697 the release code (a string of ' ' and type tfMisc) and then free
698 it up. }
699
700 Created := false;
701 if not Assigned(FWriterThread) then
702 begin
703 FWriterThread := TWriterThread.Create;
704 Created := true;
705 end;
706 FWriterThread.WriteSQLData(' ', tfMisc);
707 FReaderThread.WaitFor;
708 FreeAndNil(FReaderThread);
709 if Created then
710 begin
711 FWriterThread.Terminate;
712 FWriterThread.WaitFor;
713 FreeAndNil(FWriterThread);
714 end;
715 end;
716 end;
717
718 procedure TIBSQLMonitorHook.WriteSQLData(Text: String;
719 DataType: TTraceFlag);
720 begin
721 if not FEventsCreated then
722 CreateEvents;
723 Text := CRLF + '[Application: ' + Application.Title + ']' + CRLF + Text; {do not localize}
724 if not Assigned(FWriterThread) then
725 FWriterThread := TWriterThread.Create;
726 FWriterThread.WriteSQLData(Text, DataType);
727 end;
728
729 { TWriterThread }
730
731 constructor TWriterThread.Create;
732
733 begin
734 inherited Create(true);
735 FMsgs := TObjectList.Create(true);
736 Resume;
737 end;
738
739 destructor TWriterThread.Destroy;
740 begin
741 FMsgs.Free;
742 inherited;
743 end;
744
745 procedure TWriterThread.Execute;
746 begin
747 { Place thread code here }
748 while ((not Terminated) and (not bDone)) or
749 (FMsgs.Count <> 0) do
750 begin
751 { Any one listening? }
752 if FMonitorCount^ = 0 then
753 begin
754 if FMsgs.Count <> 0 then
755 Synchronize(RemoveFromList);
756 Sleep(50);
757 end
758 else
759 { Anything to process? }
760 if FMsgs.Count <> 0 then
761 begin
762 { If the current queued message is a release release the object }
763 if FMsgs.Items[0] is TReleaseObject then
764 PostMessage(TReleaseObject(FMsgs.Items[0]).FHandle, CM_RELEASE, 0, 0)
765 else
766 { Otherwise write the TraceObject to the buffer }
767 begin
768 WriteToBuffer;
769 end;
770 end
771 else
772 Sleep(50);
773 end;
774 { This little bit is to unlock the reader thread. bDone is normally true
775 at this point and therefor this will allow the reader thread to stop
776 waiting }
777 { WriteSQLData(' ', tfMisc);
778 WriteToBuffer; }
779 end;
780
781 procedure TWriterThread.Lock;
782 begin
783 WaitForSingleObject(FWriteLock, INFINITE);
784 end;
785
786 procedure TWriterThread.Unlock;
787 begin
788 ReleaseMutex(FWriteLock);
789 end;
790
791 procedure TWriterThread.WriteSQLData(Msg : String; DataType: TTraceFlag);
792 begin
793 FMsgs.Add(TTraceObject.Create(Msg, DataType));
794 end;
795
796 procedure TWriterThread.BeginWrite;
797 begin
798 Lock;
799 end;
800
801 procedure TWriterThread.EndWrite;
802 begin
803 {
804 * 1. Wait to end the write until all registered readers have
805 * started to wait for a write event
806 * 2. Block all of those waiting for the write to finish.
807 * 3. Block all of those waiting for all readers to finish.
808 * 4. Unblock all readers waiting for a write event.
809 * 5. Wait until all readers have finished reading.
810 * 6. Now, block all those waiting for a write event.
811 * 7. Unblock all readers waiting for a write to be finished.
812 * 8. Unlock the mutex.
813 }
814 while WaitForSingleObject(FReadEvent, cDefaultTimeout) = WAIT_TIMEOUT do
815 begin
816 if FMonitorCount^ > 0 then
817 InterlockedDecrement(FMonitorCount^);
818 if (FReaderCount^ = FMonitorCount^ - 1) or (FMonitorCount^ = 0) then
819 SetEvent(FReadEvent);
820 end;
821 ResetEvent(FWriteFinishedEvent);
822 ResetEvent(FReadFinishedEvent);
823 SetEvent(FWriteEvent); { Let all readers pass through. }
824 while WaitForSingleObject(FReadFinishedEvent, cDefaultTimeout) = WAIT_TIMEOUT do
825 if (FReaderCount^ = 0) or (InterlockedDecrement(FReaderCount^) = 0) then
826 SetEvent(FReadFinishedEvent);
827 ResetEvent(FWriteEvent);
828 SetEvent(FWriteFinishedEvent);
829 Unlock;
830 end;
831
832 procedure TWriterThread.WriteToBuffer;
833 var
834 i, len: Integer;
835 Text : String;
836 begin
837 Lock;
838 try
839 { If there are no monitors throw out the message
840 The alternative is to have messages queue up until a
841 monitor is ready.}
842
843 if FMonitorCount^ = 0 then
844 Synchronize(RemoveFromList)
845 else
846 begin
847 Text := TTraceObject(FMsgs[0]).FMsg;
848 i := 1;
849 len := Length(Text);
850 while (len > 0) do begin
851 BeginWrite;
852 try
853 FTraceDataType^ := Integer(TTraceObject(FMsgs[0]).FDataType);
854 FTimeStamp^ := TTraceObject(FMsgs[0]).FTimeStamp;
855 FBufferSize^ := Min(len, cMaxBufferSize);
856 Move(Text[i], FBuffer[0], FBufferSize^);
857 Inc(i, cMaxBufferSize);
858 Dec(len, cMaxBufferSize);
859 finally
860 {Do this in the main thread so the main thread
861 adds and deletes}
862 Synchronize(RemoveFromList);
863 EndWrite;
864 end;
865 end;
866 end;
867 finally
868 Unlock;
869 end;
870 end;
871
872 procedure TWriterThread.RemoveFromList;
873 begin
874 FMsgs.Remove(FMsgs[0]); { Pop the written item }
875 end;
876
877 procedure TWriterThread.ReleaseMonitor(HWnd: THandle);
878 begin
879 FMsgs.Add(TReleaseObject.Create(HWnd));
880 end;
881
882 { TTraceObject }
883
884 constructor TTraceObject.Create(Msg : String; DataType: TTraceFlag);
885 begin
886 FMsg := Msg;
887 FDataType := DataType;
888 FTimeStamp := Now;
889 end;
890
891 constructor TTraceObject.Create(obj: TTraceObject);
892 begin
893 FMsg := obj.FMsg;
894 FDataType := obj.FDataType;
895 FTimeStamp := obj.FTimeStamp;
896 end;
897
898 { TReleaseObject }
899
900 constructor TReleaseObject.Create(Handle: THandle);
901 begin
902 FHandle := Handle;
903 end;
904
905 { ReaderThread }
906
907 procedure TReaderThread.AddMonitor(Arg: TIBCustomSQLMonitor);
908 begin
909 EnterCriticalSection(CS);
910 if FMonitors.IndexOf(Arg) < 0 then
911 FMonitors.Add(Arg);
912 LeaveCriticalSection(CS);
913 end;
914
915 procedure TReaderThread.BeginRead;
916 begin
917 {
918 * 1. Wait for the "previous" write event to complete.
919 * 2. Increment the number of readers.
920 * 3. if the reader count is the number of interested readers, then
921 * inform the system that all readers are ready.
922 * 4. Finally, wait for the FWriteEvent to signal.
923 }
924 WaitForSingleObject(FWriteFinishedEvent, INFINITE);
925 InterlockedIncrement(FReaderCount^);
926 if FReaderCount^ = FMonitorCount^ then
927 SetEvent(FReadEvent);
928 WaitForSingleObject(FWriteEvent, INFINITE);
929 end;
930
931 constructor TReaderThread.Create;
932 begin
933 inherited Create(true);
934 st := TTraceObject.Create('', tfMisc);
935 FMonitors := TObjectList.Create(false);
936 InterlockedIncrement(FMonitorCount^);
937 Resume;
938 end;
939
940 destructor TReaderThread.Destroy;
941 begin
942 if FMonitorCount^ > 0 then
943 InterlockedDecrement(FMonitorCount^);
944 FMonitors.Free;
945 st.Free;
946 inherited;
947 end;
948
949 procedure TReaderThread.EndRead;
950 begin
951 if InterlockedDecrement(FReaderCount^) = 0 then
952 begin
953 ResetEvent(FReadEvent);
954 SetEvent(FReadFinishedEvent);
955 end;
956 end;
957
958 procedure TReaderThread.Execute;
959 var
960 i : Integer;
961 FTemp : TTraceObject;
962 begin
963 { Place thread code here }
964 while (not Terminated) and (not bDone) do
965 begin
966 ReadSQLData;
967 if (st.FMsg <> '') and
968 not ((st.FMsg = ' ') and (st.FDataType = tfMisc)) then
969 begin
970 for i := 0 to FMonitors.Count - 1 do
971 begin
972 FTemp := TTraceObject.Create(st);
973 PostMessage(TIBCustomSQLMonitor(FMonitors[i]).Handle,
974 WM_IBSQL_SQL_EVENT,
975 0,
976 LPARAM(FTemp));
977 end;
978 end;
979 end;
980 end;
981
982 procedure TReaderThread.ReadSQLData;
983 begin
984 st.FMsg := '';
985 BeginRead;
986 if not bDone then
987 try
988 SetString(st.FMsg, FBuffer, FBufferSize^);
989 st.FDataType := TTraceFlag(FTraceDataType^);
990 st.FTimeStamp := TDateTime(FTimeStamp^);
991 finally
992 EndRead;
993 end;
994 end;
995
996 procedure TReaderThread.RemoveMonitor(Arg: TIBCustomSQLMonitor);
997 begin
998 EnterCriticalSection(CS);
999 FMonitors.Remove(Arg);
1000 LeaveCriticalSection(CS);
1001 end;
1002
1003 { Misc methods }
1004
1005 function MonitorHook: IIBSQLMonitorHook;
1006 begin
1007 if (_MonitorHook = nil) and (not bDone) then
1008 begin
1009 EnterCriticalSection(CS);
1010 if (_MonitorHook = nil) and (not bDone) then
1011 begin
1012 _MonitorHook := TIBSQLMonitorHook.Create;
1013 _MonitorHook._AddRef;
1014 end;
1015 LeaveCriticalSection(CS);
1016 end;
1017 result := _MonitorHook;
1018 end;
1019
1020 procedure EnableMonitoring;
1021 begin
1022 MonitorHook.Enabled := True;
1023 end;
1024
1025 procedure DisableMonitoring;
1026 begin
1027 MonitorHook.Enabled := False;
1028 end;
1029
1030 function MonitoringEnabled: Boolean;
1031 begin
1032 result := MonitorHook.Enabled;
1033 end;
1034
1035 procedure CloseThreads;
1036 begin
1037 if Assigned(FReaderThread) then
1038 begin
1039 FReaderThread.Terminate;
1040 FReaderThread.WaitFor;
1041 FreeAndNil(FReaderThread);
1042 end;
1043 if Assigned(FWriterThread) then
1044 begin
1045 FWriterThread.Terminate;
1046 FWriterThread.WaitFor;
1047 FreeAndNil(FWriterThread);
1048 end;
1049 end;
1050
1051 initialization
1052 InitializeCriticalSection(CS);
1053 _MonitorHook := nil;
1054 FWriterThread := nil;
1055 FReaderThread := nil;
1056 bDone := False;
1057
1058 finalization
1059 try
1060 { Write an empty string to force the reader to unlock during termination }
1061 bDone := True;
1062 if Assigned(FReaderThread) then
1063 begin
1064 if not Assigned(FWriterThread) then
1065 FWriterThread := TWriterThread.Create;
1066 FWriterThread.WriteSQLData(' ', tfMisc);
1067 end;
1068 CloseThreads;
1069 if Assigned(_MonitorHook) then
1070 _MonitorHook._Release;
1071 finally
1072 _MonitorHook := nil;
1073 DeleteCriticalSection(CS);
1074 end;
1075 end.