ViewVC Help

View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing

root/public/ibx/trunk/runtime/IBSQLMonitor.pas

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

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

Diff Legend

–	Removed lines
+	Added lines
<	Changed lines
>	Changed lines