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 31 by tony, Tue Jul 14 15:31:25 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	<	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	>	{$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