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

Diff Legend

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