fibsqlmonitor.pas

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

procedure TFIBSQLMonitorHook.UnregisterMonitor(SQLMonitor: TFIBCustomSQLMonitor);
begin
  FFIBReaderThread.RemoveMonitor(SQLMonitor);
  if FFIBReaderThread.FMonitors.Count = 0 then
  begin
    FFIBReaderThread.Terminate;
    if not Assigned(FFIBWriterThread) then
    begin
      FFIBWriterThread := TMonitorWriterThread.Create;
    end;
    FFIBWriterThread.WriteSQLData(' ', tfMisc);
    FFIBReaderThread.WaitFor;
    FFIBReaderThread.Free;
    FFIBReaderThread:=nil;
  end;
end;

procedure TFIBSQLMonitorHook.WriteSQLData(const Text: String;
  DataType: TFIBTraceFlag);
var
 vText:string;
begin
  if not vEventsCreated then
  try
    CreateEvents;
  except
    Enabled := false;
    Exit;
  end;
  vText := CRLF + '[Application: ' +  ExtractFileName(ParamStr(0))+ ']' + CRLF + Text; {do not localize}
  if not Assigned(FFIBWriterThread) then
    FFIBWriterThread := TMonitorWriterThread.Create;
  FFIBWriterThread.WriteSQLData(vText, DataType);
end;


procedure TFIBSQLMonitorHook.TerminateWriteThread;
begin
  if Assigned(FFIBWriterThread) then
  begin
   FFIBWriterThread.Free;
   FFIBWriterThread:=nil
  end;
end;

{ TMonitorWriterThread }

constructor TMonitorWriterThread.Create;

begin
  StopExec:=False;
  FMonitorMsgs := TList.Create;
  inherited Create(False);
{  if FMonitorCount^ <> 0 then
   Resume;}
  {$IFNDEF D6+}
  if FMonitorCount^ = 0 then
   Suspend;
  {$ENDIF}
end;

destructor TMonitorWriterThread.Destroy;
var Msg:TObject;
begin
  {$IFNDEF D6+}
   Resume;
  {$ENDIF}
  inherited Destroy;  
  if FMonitorMsgs.Count>0 then
  begin
   Msg:=FMonitorMsgs[0];
   FMonitorMsgs.Delete(0);
   Msg.Free;
  end;
  FMonitorMsgs.Free;


end;

procedure TMonitorWriterThread.Execute;
begin
  while  (((not Terminated) and (not bDone)) or
        (FMonitorMsgs.Count <> 0)) and not StopExec do
  begin
    if (FMonitorCount^ = 0) then
    begin
     while FMonitorMsgs.Count <> 0 do
     begin
       TObject(FMonitorMsgs[0]).Free;
       FMonitorMsgs.Delete(0);
//       FMonitorMsgs.Remove(FMonitorMsgs[0]);
     end;

     {$IFNDEF D6+}
      Suspend;
     {$ELSE}
       Sleep(50)
     {$ENDIF}
    end
    else
      if FMonitorMsgs.Count <> 0 then
      begin
        if (TObject(FMonitorMsgs.Items[0]) is TReleaseObject)
//or (not bEnabledMonitoring )         
        then
          PostMessage(TReleaseObject(FMonitorMsgs.Items[0]).FHandle, CM_RELEASE, 0, 0)
        else
        begin
          if bEnabledMonitoring  then
           WriteToBuffer
          else
          begin
//            WriteToBuffer;

            BeginWrite;
            TFIBTraceObject(FMonitorMsgs[0]).Free;
            FMonitorMsgs.Delete(0);
            EndWrite;
          end;
        end;
      end
      else
     {$IFNDEF D6+}
        Suspend
     {$ELSE}
       Sleep(50)
     {$ENDIF}
  end;
end;

procedure TMonitorWriterThread.Lock;
begin
  WaitForSingleObject(FWriteLock, INFINITE);
end;

procedure TMonitorWriterThread.Unlock;
begin
  ReleaseMutex(FWriteLock);
end;

procedure TMonitorWriterThread.WriteSQLData(Msg : String; DataType: TFIBTraceFlag);
begin
  if (FMonitorCount^ <> 0)   then
  begin
    FMonitorMsgs.Add(TFIBTraceObject.Create(Msg, DataType));
   {$IFNDEF D6+}
    Resume;
   {$ENDIF}
  end
  else
  begin
   FreeAndNil(FFIBWriterThread)
  end;
end;

procedure TMonitorWriterThread.BeginWrite;
begin
  Lock;
end;

procedure TMonitorWriterThread.EndWrite;
begin
  {
   * 1. Wait to end the write until all registered readers have
   *    started to wait for a write event
   * 2. Block all of those waiting for the write to finish.
   * 3. Block all of those waiting for all readers to finish.
   * 4. Unblock all readers waiting for a write event.
   * 5. Wait until all readers have finished reading.
   * 6. Now, block all those waiting for a write event.
   * 7. Unblock all readers waiting for a write to be finished.
   * 8. Unlock the mutex.
   }
  while WaitForSingleObject(FReadEvent, cDefaultTimeout) = WAIT_TIMEOUT do
  begin
    if FMonitorCount^ > 0 then
      InterlockedDecrement(FMonitorCount^);
    if (FReaderCount^ = FMonitorCount^ - 1) or (FMonitorCount^ = 0) then
      SetEvent(FReadEvent);
  end;
  ResetEvent(FWriteFinishedEvent);
  ResetEvent(FReadFinishedEvent);
  SetEvent(FWriteEvent); { Let all readers pass through. }
  while WaitForSingleObject(FReadFinishedEvent, cDefaultTimeout) = WAIT_TIMEOUT do
    if (FReaderCount^ = 0) or (InterlockedDecrement(FReaderCount^) = 0) then
      SetEvent(FReadFinishedEvent);
  ResetEvent(FWriteEvent);
  SetEvent(FWriteFinishedEvent);
  Unlock;
end;

procedure TMonitorWriterThread.WriteToBuffer;
var
  i, len: Integer;
  Text : String;
  ps   :PString;
begin
  Lock;
  try
    if FMonitorCount^ = 0 then
       FMonitorMsgs.Remove(FMonitorMsgs[0])
    else
    begin
      ps    :=@TFIBTraceObject(FMonitorMsgs[0]).FMsg;
      Text  := '';
      for i := 1 to length(ps^) do
      begin
       if ord(ps^[i]) in [0..8,$B,$C,$E..31] then
        Text := Text + '#$'+IntToHex(ord(ps^[i]),2)
       else
        Text := Text + ps^[i];
      end;
      i := 1;
      len := Length(Text);
      while (len > 0) do
      begin
        BeginWrite;
        try
          FTraceDataType^ := Integer(TFIBTraceObject(FMonitorMsgs[0]).FDataType);
          FTimeStamp^ := TFIBTraceObject(FMonitorMsgs[0]).FTimeStamp;
          FBufferSize^ := Min(len, cMaxBufferSize);
          Move(Text[i], FBuffer[0], FBufferSize^);
          Inc(i, cMaxBufferSize);
          Dec(len, cMaxBufferSize);
        finally
          EndWrite;
        end;
      end;
    end;
    if FMonitorMsgs.Count>0 then
    begin
      TFIBTraceObject(FMonitorMsgs[0]).Free;
      FMonitorMsgs.Delete(0);
    end;
  finally
    Unlock;
  end;
end;


procedure TMonitorWriterThread.ReleaseMonitor(HWnd: THandle);
begin
  FMonitorMsgs.Add(TReleaseObject.Create(HWnd));
end;

{ TFIBTraceObject }

constructor TFIBTraceObject.Create(Msg : String; DataType: TFIBTraceFlag);
begin
  FMsg := Msg;
  FDataType := DataType;
  FTimeStamp := Now;
end;

{TReleaseObject}

constructor TReleaseObject.Create(Handle: THandle);
begin
  FHandle := Handle;
end;

{ReaderThread}

procedure TMonitorReaderThread.AddMonitor(Arg: TFIBCustomSQLMonitor);
begin
  EnterCriticalSection(CS);
  if FMonitors.IndexOf(Arg) < 0 then
    FMonitors.Add(Arg);
  LeaveCriticalSection(CS);
end;

procedure TMonitorReaderThread.BeginRead;
begin
  {
   * 1. Wait for the "previous" write event to complete.
   * 2. Increment the number of readers.
   * 3. if the reader count is the number of interested readers, then
   *    inform the system that all readers are ready.
   * 4. Finally, wait for the FWriteEvent to signal.
   }
  WaitForSingleObject(FWriteFinishedEvent, INFINITE);
  InterlockedIncrement(FReaderCount^);
  if FReaderCount^ = FMonitorCount^ then
    SetEvent(FReadEvent);
  WaitForSingleObject(FWriteEvent, INFINITE);
end;

constructor TMonitorReaderThread.Create;
begin
  inherited Create(true);
  st := TFIBTraceObject.Create('', tfMisc);
  FMonitors := TList.Create;
  InterlockedIncrement(FMonitorCount^);
  Resume;
end;

destructor TMonitorReaderThread.Destroy;
begin
  inherited Destroy;
  if FMonitorCount^ > 0 then
    InterlockedDecrement(FMonitorCount^);
  FMonitors.Free;
  st.Free;

end;

procedure TMonitorReaderThread.EndRead;
begin
  if InterlockedDecrement(FReaderCount^) = 0 then
  begin
    ResetEvent(FReadEvent);
    SetEvent(FReadFinishedEvent);
  end;
end;


procedure TMonitorReaderThread.Execute;
var
  i : Integer;
  FTemp : TFIBTraceObject;
begin
  while (not Terminated) and (not bDone) do
  begin
    ReadSQLData;
    if not IsBlank(st.FMsg) then
      for i := 0 to FMonitors.Count - 1 do
      begin
        FTemp := TFIBTraceObject.Create(st.FMsg,  st.FDataType);
        PostMessage(TFIBCustomSQLMonitor(FMonitors[i]).Handle,
          WM_FIBSQL_SQL_EVENT,  0, LPARAM(FTemp)
        );
      end;
  end;
end;

procedure TMonitorReaderThread.ReadSQLData;
begin
  st.FMsg := '';
  BeginRead;
  if not bDone then
  try
    SetString(st.FMsg, FBuffer, FBufferSize^);
    st.FDataType := TFIBTraceFlag(FTraceDataType^);
    st.FTimeStamp := TDateTime(FTimeStamp^);
  finally
    EndRead;
  end;
end;

procedure TMonitorReaderThread.RemoveMonitor(Arg: TFIBCustomSQLMonitor);
begin
  EnterCriticalSection(CS);
  FMonitors.Remove(Arg);
  LeaveCriticalSection(CS);
end;



function MonitorHook: TFIBSQLMonitorHook;
begin
{  if not bEnabledMonitoring then
  begin
   Result :=nil; Exit;
  end;}
  if (_MonitorHook = nil) and (not bDone) then
  begin
    EnterCriticalSection(CS);
    if (_MonitorHook = nil) and (not bDone) then
    begin
      _MonitorHook := TFIBSQLMonitorHook.Create;
    end;
    LeaveCriticalSection(CS);
  end;
  Result := _MonitorHook
end;

procedure EnableMonitoring;
begin
  bEnabledMonitoring:=true;
end;

procedure DisableMonitoring;
begin
  bEnabledMonitoring  :=false;
end;

function MonitoringEnabled: Boolean;
begin
  Result := bEnabledMonitoring and ((FMonitorCount=nil) or(FMonitorCount^>0));
end;


initialization
{$IFNDEF NO_MONITOR}
  InitializeCriticalSection(CS);
  _MonitorHook := nil;
  FFIBWriterThread := nil;
  FFIBReaderThread := nil;
  bDone := False;
  bEnabledMonitoring:=true;
{$ENDIF}
finalization
{$IFNDEF NO_MONITOR}
  try
     bDone := True;
     FreeAndNil(FFIBReaderThread);
     {$IFDEF D6+}
     if Assigned(FFIBWriterThread) then
     begin
      FFIBWriterThread.StopExec:=True;
      FFIBWriterThread.Terminate;
      FFIBWriterThread.WaitFor;
     end;
     {$ELSE}
      if Assigned(FFIBWriterThread) and not FFIBWriterThread.Suspended then
       FFIBWriterThread.Suspend;
     {$ENDIF}
     FreeAndNil(FFIBWriterThread);
     if Assigned(_MonitorHook) then   _MonitorHook.Free;
  finally
    _MonitorHook := nil;
    DeleteCriticalSection(CS);
  end;
{$ENDIF}
{$ENDIF}
end.