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

Diff Legend

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