fibsqlmonitor.pas

FIBPlus is a component suite intended for work with InterBase. It is direct, fast and flexible Inter

{***************************************************************}
{ FIBPlus - component library for direct access to Firebird and }
{ InterBase databases                                           }
{                                                               }
{    FIBPlus is based in part on the product                    }
{    Free IB Components, written by Gregory H. Deatz for        }
{    Hoagland, Longo, Moran, Dunst & Doukas Company.            }
{    mailto:[e-mail]                                    }
{                                                               }
{    Copyright (c) 1998-2007 Devrace Ltd.                       }
{    Written by Serge Buzadzhy ([e-mail])               }
{                                                               }
{ ------------------------------------------------------------- }
{    FIBPlus home page: http://www.fibplus.com/                 }
{    FIBPlus support  : http://www.devrace.com/support/         }
{ ------------------------------------------------------------- }
{                                                               }
{  Please see the file License.txt for full license information }
{***************************************************************}


unit FIBSQLMonitor;

interface

{$I FIBPlus.inc}
uses
 {$IFDEF WINDOWS}
  SysUtils, Windows, Messages, Classes, FIBQuery,ibase,
  FIBDataSet, FIBDatabase
  {$IFNDEF D6+}
   ,Forms
  {$ENDIF}
  {$IFDEF  INC_SERVICE_SUPPORT}
  ,IB_Services
  {$ENDIF}
;

 {$ENDIF}
 {$IFDEF LINUX}
  SysUtils, Types, Classes,  FIBQuery,ibase,
  FIBDataSet, FIBDatabase,Libc
  {$IFDEF  INC_SERVICE_SUPPORT}
  ,IB_Services
  {$ENDIF}
;
 {$ENDIF}


{$IFNDEF NO_MONITOR}
const
  WM_MIN_FIBSQL_MONITOR = WM_USER;
  WM_MAX_FIBSQL_MONITOR = WM_USER + 512;
  WM_FIBSQL_SQL_EVENT   = WM_MIN_FIBSQL_MONITOR + 1;
  CM_RELEASE            = $B000 + 33; // cut from Controls

type
  TFIBCustomSQLMonitor = class;
  TFIBTraceFlag = (tfQPrepare, tfQExecute, tfQFetch,
   tfConnect, tfTransact,tfService,tfMisc
  );
  TFIBTraceFlags = set of TFIBTraceFlag;

 { TFIBSQLMonitor }
  TSQLEvent = procedure(EventText: String; EventTime : TDateTime) of object;

  TFIBCustomSQLMonitor = class(TComponent)
  private
    FHWnd: HWND;
    FOnSQLEvent: TSQLEvent;
    FTraceFlags: TFIBTraceFlags;
    FActive: Boolean;
{$IFNDEF LINUX}
    procedure MonitorWndProc(var Message : TMessage);
{$ENDIF}
    procedure SetActive(const Value: Boolean);
    procedure SetTraceFlags(aTraceFlags:TFIBTraceFlags);
  protected
    property OnSQL: TSQLEvent read FOnSQLEvent write FOnSQLEvent;
    property TraceFlags: TFIBTraceFlags read FTraceFlags write SetTraceFlags;
    property Active    : Boolean read FActive write SetActive default true;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure  Release;
{$IFNDEF LINUX}
    property   Handle : HWND read FHwnd;
{$ENDIF}
  end;

  TFIBSQLMonitor = class(TFIBCustomSQLMonitor)
  published
    property OnSQL;
    property TraceFlags;
    property Active;
  end;

  TSavePointOperation=(soSet,soRollBack,soRelease);

  { TFIBSQLMonitorHook }
  TFIBSQLMonitorHook = class(TObject)
  private
    FActive: Boolean;
    vEventsCreated : Boolean;
    procedure CreateEvents;
  protected
    procedure WriteSQLData(const Text: String; DataType: TFIBTraceFlag);
  public
    constructor Create;
    destructor Destroy; override;
    procedure TerminateWriteThread;
    function  SQLString(k:integer):Byte;     
    procedure RegisterMonitor(SQLMonitor : TFIBCustomSQLMonitor);
    procedure UnregisterMonitor(SQLMonitor : TFIBCustomSQLMonitor);
    procedure ReleaseMonitor(Arg : TFIBCustomSQLMonitor);
    procedure SQLPrepare(qry: TFIBQuery); virtual;
    procedure SQLExecute(qry: TFIBQuery); virtual;
    procedure SQLFetch(qry: TFIBQuery); virtual;
    procedure DBConnect(db: TFIBDatabase); virtual;
    procedure DBDisconnect(db: TFIBDatabase); virtual;
    procedure TRStart(tr: TFIBTransaction); virtual;
    procedure TRCommit(tr: TFIBTransaction); virtual;
    procedure TRSavepoint(tr: TFIBTransaction; const SavePointName:string;
     Operation:TSavePointOperation); virtual;
    procedure TRCommitRetaining(tr: TFIBTransaction); virtual;
    procedure TRRollback(tr: TFIBTransaction); virtual;
    procedure TRRollbackRetaining(tr: TFIBTransaction); virtual;
   {$IFDEF  INC_SERVICE_SUPPORT}
    procedure ServiceAttach(service: TpFIBCustomService); virtual;
    procedure ServiceDetach(service: TpFIBCustomService); virtual;
    procedure ServiceQuery(service: TpFIBCustomService); virtual;
    procedure ServiceStart(service: TpFIBCustomService); virtual;
   {$ENDIF}
    procedure SendMisc(Msg : String);
    function  GetEnabled: Boolean;
    function  GetMonitorCount : Integer;
    procedure SetEnabled(const Value: Boolean);
    property Enabled : Boolean read GetEnabled write SetEnabled default true;
  end;


function  MonitorHook: TFIBSQLMonitorHook;
procedure EnableMonitoring;
procedure DisableMonitoring;
function  MonitoringEnabled: Boolean;
{$ENDIF}
implementation

{$IFNDEF NO_MONITOR}
uses
  fib, StdFuncs,StrUtil;

type

  TFIBTraceObject = Class(TObject)
  private
    FDataType : TFIBTraceFlag;
    FMsg : String;
    FTimeStamp : TDateTime;
  public
    constructor Create(Msg : String; DataType : TFIBTraceFlag);
  end;

  TReleaseObject = Class(TObject)
  private
    FHandle : THandle;
  public
    constructor Create(Handle : THandle);
  end;

  TMonitorWriterThread = class(TThread)
  private
    StopExec:boolean;
    FMonitorMsgs : TList;
  protected
    procedure Lock;
    Procedure Unlock;
    procedure BeginWrite;
    procedure EndWrite;
    procedure Execute; override;
    procedure WriteToBuffer;
  public
    constructor Create;
    destructor Destroy; override;
    procedure WriteSQLData(Msg : String; DataType : TFIBTraceFlag);
    procedure ReleaseMonitor(HWnd : THandle);
  end;

  TMonitorReaderThread = class(TThread)
  private
    st : TFIBTraceObject;
    FMonitors : TList;
  protected
    procedure BeginRead;
    procedure EndRead;
    procedure ReadSQLData;
    procedure Execute; override;
  public
    constructor Create;
    destructor Destroy; override;
    procedure  AddMonitor(Arg : TFIBCustomSQLMonitor);
    procedure  RemoveMonitor(Arg : TFIBCustomSQLMonitor);
  end;

const
  MonitorHookNames: array[0..5] of String = (
    'FIB.SQL.MONITOR.Mutex',
    'FIB.SQL.MONITOR.SharedMem',
    'FIB.SQL.MONITOR.WriteEvent',
    'FIB.SQL.MONITOR.WriteFinishedEvent',
    'FIB.SQL.MONITOR.ReadEvent',
    'FIB.SQL.MONITOR.ReadFinishedEvent'
  );
  cMonitorHookSize = 2048;
  cMaxBufferSize = cMonitorHookSize - (9 * SizeOf(Integer)) - SizeOf(TDateTime)
  - 2*SizeOf(Byte)
  ;
  cDefaultTimeout = 1000; // 1 seconds

var
  FSharedBuffer,
  FWriteLock,
  FWriteEvent,
  FWriteFinishedEvent,
  FReadEvent,
  FReadFinishedEvent : THandle;
  FBuffer : PChar;
  FMonitorCount,
  FReaderCount,
  FTraceDataType,
  FQPrepareReaderCount,
  FQExecuteReaderCount,
  FQFetchReaderCount,
  FConnectReaderCount,
  FTransactReaderCount,
  FBufferSize : PInteger;
  FTimeStamp  : PDateTime;
  FReserved   : PByte;
  FReserved1  : PByte;

  FFIBWriterThread : TMonitorWriterThread;
  FFIBReaderThread : TMonitorReaderThread;
  _MonitorHook: TFIBSQLMonitorHook;
  bDone: Boolean;
  CS : TRTLCriticalSection;
  bEnabledMonitoring:boolean;
{ TFIBCustomSQLMonitor }


{$IFDEF D6+}
{$WARN SYMBOL_DEPRECATED OFF}
{$ENDIF}
constructor TFIBCustomSQLMonitor.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FActive := true;
  if not (csDesigning in ComponentState) then
  begin
{$IFNDEF LINUX}
    FHWnd := AllocateHWnd(MonitorWndProc);
{$ENDIF}
    MonitorHook.RegisterMonitor(self);
  end;
  TraceFlags := [tfqPrepare .. tfTransact];
end;


destructor TFIBCustomSQLMonitor.Destroy;
begin
  if not (csDesigning in ComponentState) then
  begin
   if (tfQPrepare in TraceFlags)   then
    InterlockedDecrement(FQPrepareReaderCount^);
   if (tfQExecute in TraceFlags)   then
    InterlockedDecrement(FQExecuteReaderCount^);
   if (tfQFetch in TraceFlags)     then
    InterlockedDecrement(FQFetchReaderCount^);

   if (tfConnect in TraceFlags)  then
    InterlockedDecrement(FConnectReaderCount^);
   if (tfTransact in TraceFlags) then
    InterlockedDecrement(FTransactReaderCount^);

   if FActive then
      MonitorHook.UnregisterMonitor(self);
{$IFNDEF LINUX}
    DeallocateHwnd(FHWnd);
{$ENDIF}
  end;
  inherited Destroy;
end;
{$IFDEF D6+}
 {$WARN SYMBOL_DEPRECATED ON}
{$ENDIF}
{$IFNDEF LINUX}



procedure TFIBCustomSQLMonitor.MonitorWndProc(var Message: TMessage);
var
  st : TFIBTraceObject;
begin
  case Message.Msg of
    WM_FIBSQL_SQL_EVENT:
    begin
      st := TFIBTraceObject(Message.LParam);
      if (Assigned(FOnSQLEvent)) and
         (st.FDataType in FTraceFlags) then
        FOnSQLEvent(st.FMsg, st.FTimeStamp);
      st.Free;
    end;
    CM_RELEASE :
      Free;
  else
      Message.Result := DefWindowProc(FHWnd, Message.Msg, Message.WParam, Message.LParam);
  end;
end;
{$ENDIF}

procedure TFIBCustomSQLMonitor.Release;
begin
  MonitorHook.ReleaseMonitor(self);
end;

procedure TFIBCustomSQLMonitor.SetActive(const Value: Boolean);
begin
  if Value <> FActive then
  begin
    FActive := Value;
    if not (csDesigning in ComponentState) then
      if FActive then
        Monitorhook.RegisterMonitor(self)
      else
        MonitorHook.UnregisterMonitor(self);
  end;
end;

procedure TFIBCustomSQLMonitor.SetTraceFlags(aTraceFlags:TFIBTraceFlags);
begin
 if not (csDesigning in ComponentState) then
 begin
  if (tfQPrepare in TraceFlags) and not (tfQPrepare in aTraceFlags)
  then
   InterlockedDecrement(FQPrepareReaderCount^)
  else
  if (not (tfQPrepare in TraceFlags)) and (tfQPrepare in aTraceFlags)
  then
   InterlockedIncrement(FQPrepareReaderCount^);

  if (tfQExecute in TraceFlags) and not (tfQExecute in aTraceFlags)
  then
   InterlockedDecrement(FQExecuteReaderCount^)
  else
  if (not (tfQExecute in TraceFlags)) and (tfQExecute in aTraceFlags)
  then
   InterlockedIncrement(FQExecuteReaderCount^);

  if (tfQFetch in TraceFlags) and not (tfQFetch in aTraceFlags)
  then
   InterlockedDecrement(FQFetchReaderCount^)
  else
  if (not (tfQFetch in TraceFlags)) and (tfQFetch in aTraceFlags)
  then
   InterlockedIncrement(FQFetchReaderCount^);

  if (tfConnect in TraceFlags) and not (tfConnect in aTraceFlags)
  then
   InterlockedDecrement(FConnectReaderCount^)
  else
  if (not (tfConnect in TraceFlags)) and (tfConnect in aTraceFlags)
  then
   InterlockedIncrement(FConnectReaderCount^);

  if (tfTransact in TraceFlags) and not (tfTransact in aTraceFlags)
  then
   InterlockedDecrement(FTransactReaderCount^)
  else
  if (not (tfTransact in TraceFlags)) and (tfTransact in aTraceFlags)
  then
   InterlockedIncrement(FTransactReaderCount^);
 end;
 fTraceFlags:=aTraceFlags
end;

{ TFIBSQLMonitorHook }

constructor TFIBSQLMonitorHook.Create;
begin
  inherited Create;
  vEventsCreated := false;

  FActive := true;
  if not vEventsCreated then
  try
    CreateEvents;
  except
    Enabled := false;
    Exit;
  end;
end;

procedure TFIBSQLMonitorHook.CreateEvents;
var
  Sa : TSecurityAttributes;
  Sd : TSecurityDescriptor;
  MapError: Integer;

{$IFDEF VER100}
const
  SECURITY_DESCRIPTOR_REVISION = 1;
{$ENDIF}

  function OpenLocalEvent(Idx: Integer): THandle;
  begin
    Result := OpenEvent(EVENT_ALL_ACCESS, true, PChar(MonitorHookNames[Idx]));
    if Result = 0 then
      FIBError(feCannotCreateSharedResource, [GetLastError]);
  end;

  function CreateLocalEvent(Idx: Integer; InitialState: Boolean): THandle;
  begin
    Result := CreateEvent(@sa, true, InitialState, PChar(MonitorHookNames[Idx]));
    if Result = 0 then
      FIBError(feCannotCreateSharedResource, [GetLastError]);
  end;

begin
  InitializeSecurityDescriptor(@Sd,SECURITY_DESCRIPTOR_REVISION);
  SetSecurityDescriptorDacl(@Sd,true,nil,false);
  Sa.nLength := SizeOf(Sa);
  Sa.lpSecurityDescriptor := @Sd;
  Sa.bInheritHandle := true;