fibsqlmonitor.pas

FIBPlus version 6-96. This is somewhat usefull interbase database components. TFIBDatabase, TFIBTab

{***************************************************************}
{ 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;
    FIsUnicodeVersion:boolean;
  public
    constructor Create(const 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(const 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:PAnsiChar;
  FMonitorCount,
  FReaderCount,
  FTraceDataType,
  FQPrepareReaderCount,
  FQExecuteReaderCount,
  FQFetchReaderCount,
  FConnectReaderCount,
  FTransactReaderCount,
  FBufferSize:PInteger;
  FTimeStamp:PDateTime;
  FIsUnicodeVersion:PBoolean;
  FReserved: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
      begin
       if st.FIsUnicodeVersion then
        FOnSQLEvent(UTF8Decode(st.FMsg), st.FTimeStamp)
       else
        FOnSQLEvent(st.FMsg, st.FTimeStamp);
      end;
      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);