fibsqlmonitor.pas

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

      WriteSQLData(st, tfTransact);
    end;
  end;
end;

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(const 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:AnsiString;
  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+UTF8Encode(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;
          FIsUnicodeVersion^:=True;
          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(const 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);
        FTemp.FIsUnicodeVersion:=st.FIsUnicodeVersion;
        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, PAnsiChar(FBuffer), FBufferSize^);
    st.FDataType:= TFIBTraceFlag(FTraceDataType^);
    st.FTimeStamp:= TDateTime(FTimeStamp^);
    st.FIsUnicodeVersion:=FIsUnicodeVersion^;
    FIsUnicodeVersion^:=False;
  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.