GetExtendedTcpTable - Process ID

[JannesDKS]

Hallo Leute,

ich möchte das Tool ibconsvc (InterBase Connections Service), dass mit Hilfe von GetTcpTable Informationen zu den aktiven Verbindungen zum Firebird-Server auswertet, sohingehend erweitern, dass auch der genutzte Arbeitsspeicher der Tasks angezeigt wird.
Um den benötigten Speicher zu ermitteln, brauche ich, wenn ich das richtig verstanden habe, die Process ID (PID). diese wird von der API GetTcpTable nicht geliefert, jedoch von GetExtendedTcpTable, als dwOwningPid.
Also habe ich den Quellcode dahingehend angepasst. Es wird mir jetzt auch eine PID zurückgeliefert, die ist aber immer von der ersten Connection.
Ich bin mit der Komplexität des Quellcodes leicht überfordert. Sieht einer von euch vielleicht meinen Fehler?

Delphi-Quellcode:

unit SvcMain;

{$O-}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Menus, ActnList, ComCtrls, SvcMgr, WinSock, ShellApi,psApi;

const
  WM_IBCONSVCICON = WM_USER + 1;
  ANY_SIZE = 512;
  CONFIG_FILE = 'IBConnections.cfg';

  { Specifies the state of the TCP connection }

  MIB_TCP_STATE_CLOSED = 1;
  MIB_TCP_STATE_LISTEN = 2;
  MIB_TCP_STATE_SYN_SENT = 3;
  MIB_TCP_STATE_SYN_RCVD = 4;
  MIB_TCP_STATE_ESTAB = 5;
  MIB_TCP_STATE_FIN_WAIT1 = 6;
  MIB_TCP_STATE_FIN_WAIT2 = 7;
  MIB_TCP_STATE_CLOSE_WAIT = 8;
  MIB_TCP_STATE_CLOSING = 9;
  MIB_TCP_STATE_LAST_ACK = 10;
  MIB_TCP_STATE_TIME_WAIT = 11;
  MIB_TCP_STATE_DELETE_TCB = 12;

type
  TIBConForm = class(TForm)
    ActionList: TActionList;
    actStart: TAction;
    actStop: TAction;
    actPause: TAction;
    actContinue: TAction;
    PopupMenu: TPopupMenu;
    actOpen: TAction;
    piOpen: TMenuItem;
    actExit: TAction;
    N2: TMenuItem;
    piExit: TMenuItem;
    N1: TMenuItem;
    piStart: TMenuItem;
    piStop: TMenuItem;
    piPause: TMenuItem;
    piContinue: TMenuItem;
    StatusBar: TStatusBar;
    ListView: TListView;
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormDestroy(Sender: TObject);
    procedure ListViewColumnClick(Sender: TObject; Column: TListColumn);
    procedure ListViewCompare(Sender: TObject; Item1, Item2: TListItem;
      Data: Integer; var Compare: Integer);
    procedure actStartExecute(Sender: TObject);
    procedure actStopExecute(Sender: TObject);
    procedure actPauseExecute(Sender: TObject);
    procedure actContinueExecute(Sender: TObject);
    procedure actOpenExecute(Sender: TObject);
    procedure actExitExecute(Sender: TObject);
  private
    { Private declarations }
    FFromApp: Boolean;
    FAscending: Boolean;
    FSortCol: Integer;
    FNotifyIconData: TNotifyIconData;
    procedure UpdateStatus;
    function GetProcessMemorySize(ProcessID: Integer): String;
  protected
    procedure WMIBConSvcIcon(var Message: TMessage); message WM_IBCONSVCICON;
  public
    { Public declarations }
    procedure Initialize(FromApp: Boolean);
  end;

  TIBConService = class(TService)
  protected
    procedure Start(Sender: TService; var Started: Boolean);
    procedure Stop(Sender: TService; var Stopped: Boolean);
    procedure Pause(Sender: TService; var Paused: Boolean);
    procedure Continue(Sender: TService; var Continued: Boolean);
  public
    function GetServiceController: TServiceController; override;
    constructor CreateNew(AOwner: TComponent; Dummy: Integer = 0); override;
  end;

  PMibTcpRow = ^TMibTcpRow;
  TMibTcpRow = packed record
    dwState: DWORD;
    dwLocalAddr: DWORD;
    dwLocalPort: DWORD;
    dwRemoteAddr: DWORD;
    dwRemotePort: DWORD;
    dwOwningPid: DWORD;
  end;

  PMibTcpTable = ^TMibTcpTable;
  TMibTcpTable = packed record
    dwNumEntries: DWORD;
    table: array[0..ANY_SIZE - 1] of TMibTcpRow;
  end;

  PIBConRow = ^TIBConRow;
  TIBConRow = packed record
    dwState: DWORD;
    dwRemoteAddr: DWORD;
    dwRemotePort: DWORD;
    HostName: string;
    dtConnect: TDateTime;
    dtDisconnect: TDateTime;
    MemSize : String
  end;

  PIBConTable = ^TIBConTable;
  TIBConTable = packed record
    dwNumEntries: DWORD;
    table: array[0..ANY_SIZE - 1] of TIBConRow;
  end;

  TIBConThread = class(TThread)
  private
    FIBConTable: TIBConTable;
    FCurRow: PIBConRow;
  protected
    procedure Execute; override;
    procedure AddConnect;
    procedure RemoveConnect;
  end;

  TIBFindThread = class(TThread)
  protected
    procedure Execute; override;
  end;

resourcestring
  SApplicationName = 'InterBase Connections';
  SServiceName = 'InterBaseConnections';
  SFmtStr = '%s (%s)'#9'%s'#13#10#9'%s: IP Address - %s, HostName - %s'#13#10#13#10#13#10;
  SDTFmtStr = 'ddd mmm dd hh:nn:ss yyyy';
  SFmtSingleStr = '%-15s%-255s%-19s%-19s'#13#10;
  SDTFmtSingleStr = 'mm/dd/yyyy hh:nn:ss';
  SStatusLine = '%d current connections';

const
  TCP_TABLE_OWNER_PID_ALL = 5;
  AF_INET = 2;

type
  TCP_TABLE_CLASS = Integer;
  ULONG = Longword;

function GetExtendedTcpTable(pTcpTable: Pointer; dwSize: PDWORD; bOrder: BOOL;
  lAf: ULONG; TableClass: TCP_TABLE_CLASS; Reserved: ULONG): DWord; stdcall; external 'iphlpapi.dll' name 'GetExtendedTcpTable'; // TCP Table + PID


var
  IBConForm: TIBConForm;
  IBConService: TIBConService;
  IBConThread: TIBConThread;
  IBFindThread: TIBFindThread;
  IBPort, TimeOut: DWORD;
  LogFile: string;
  SingleLine: Boolean;
  ComputerName: array[0..MAX_COMPUTERNAME_LENGTH] of Char;

implementation

{$R *.DFM}

function FormatIP(Value: DWORD): string;
begin
  Result := Format('%d.%d.%d.%d', [Value and $FF,
                                  (Value shr 8) and $FF,
                                  (Value shr 16) and $FF,
                                  (Value shr 24) and $FF]);
end;

{ TIBConForm }

procedure TIBConForm.FormCreate(Sender: TObject);
var
  ConfigList: TStrings;
  StartupDir: string;
  dwSize: DWORD;
  WSAData: TWSAData;
begin
  ConfigList := TStringList.Create;
  with ConfigList do
  try
    StartupDir := Copy(ParamStr(0), 1, LastDelimiter('\', ParamStr(0)));
    try
      LoadFromFile(StartupDir + CONFIG_FILE);
    except
      on E: Exception do
      begin
        MessageBox(0, PChar(E.Message), PChar(SApplicationName), MB_OK or MB_ICONERROR);
        Halt;
      end;
    end;
    IBPort := StrToInt(Values['Port']);
    LogFile := Values['LogFile'];
    TimeOut := StrToInt(Values['TimeOut']);
    SingleLine := StrToBool(Values['SingleLine']);
  finally
    Free;
  end;
  Caption := SApplicationName;
  with FNotifyIconData do
  begin
    cbSize := SizeOf(FNotifyIconData);
    Wnd := Handle;
    uID := $EF;
    uFlags := NIF_MESSAGE or NIF_ICON or NIF_TIP;
    uCallbackMessage := WM_IBCONSVCICON;
    hIcon := Forms.Application.Icon.Handle;
    StrPCopy(szTip, SApplicationName);
  end;
  Shell_NotifyIcon(NIM_ADD, @FNotifyIconData);
  FSortCol := -1;
  UpdateStatus;
  dwSize := SizeOf(ComputerName);
  GetComputerName(ComputerName, dwSize);
  SetThreadLocale($0409);
  GetFormatSettings;
  WSAStartup($0101, WSAData);
  SetPriorityClass(GetCurrentProcess, IDLE_PRIORITY_CLASS);
end;

procedure TIBConForm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Hide;
  Action := caNone;
end;

procedure TIBConForm.FormDestroy(Sender: TObject);
begin
  Shell_NotifyIcon(NIM_DELETE, @FNotifyIconData);
  WSACleanup;
end;

procedure TIBConForm.ListViewColumnClick(Sender: TObject;
  Column: TListColumn);
begin
  if FSortCol <> Column.Index then
    FAscending := True;
  ListView.CustomSort(nil, Column.Index - 1);
  FAscending := not FAscending;
  FSortCol := Column.Index;
end;

procedure TIBConForm.ListViewCompare(Sender: TObject; Item1,
  Item2: TListItem; Data: Integer; var Compare: Integer);

  function AlignIP(const IPAddress: string): string;
  var
    A: array[0..3] of string[4];
    ip: string;
    i: Integer;
  begin
    Result := '';
    ip := IPAddress;
    for i := 0 to High(A) do
    begin
      if Pos('.', ip) > 0 then
        A[i] := Copy(ip, 1, Pos('.', ip) - 1)
      else
        A[i] := ip;
      Delete(ip, 1, Pos('.', ip));
    end;
    Result := Format('%3s.%3s.%3s.%3s', [A[0], A[1], A[2], A[3]]);
  end;

var
  SortFlag: Integer;
begin
  if FAscending then SortFlag := 1 else SortFlag := -1;
  if Data = -1 then
    Compare := SortFlag * AnsiCompareText(AlignIP(Item1.Caption),
                                          AlignIP(Item2.Caption))
  else
    Compare := SortFlag * AnsiCompareText(Item1.SubItems[Data],
                                          Item2.SubItems[Data]);
end;

procedure TIBConForm.actStartExecute(Sender: TObject);
begin
  IBConThread := TIBConThread.Create(False);
  IBFindThread := TIBFindThread.Create(False);
  if FFromApp then
  begin
    actStart.Enabled := not actStart.Enabled;
    actStop.Enabled := True;
    actPause.Enabled := True;
    actContinue.Enabled := False;
  end;
end;

procedure TIBConForm.actStopExecute(Sender: TObject);
begin
  IBConThread.Terminate;
  IBFindThread.Terminate;
  if FFromApp then
  begin
    actStop.Enabled := not actStop.Enabled;
    actStart.Enabled := True;
    actPause.Enabled := False;
    actContinue.Enabled := False;
    ListView.Items.Clear;
    UpdateStatus;
  end;
end;

procedure TIBConForm.actPauseExecute(Sender: TObject);
begin
  IBConThread.Suspend;
  IBFindThread.Suspend;
  if FFromApp then
  begin
    actPause.Enabled := not actPause.Enabled;
    actContinue.Enabled := True;
  end;
end;

procedure TIBConForm.actContinueExecute(Sender: TObject);
begin
  IBConThread.Resume;
  IBFindThread.Resume;
  if FFromApp then
  begin
    actContinue.Enabled := not actContinue.Enabled;
    actPause.Enabled := True;
  end;
end;

procedure TIBConForm.actOpenExecute(Sender: TObject);
begin
  Show;
  ShowWindow(Forms.Application.Handle, SW_HIDE);
end;

procedure TIBConForm.actExitExecute(Sender: TObject);
begin
  Forms.Application.Terminate;
end;

procedure TIBConForm.UpdateStatus;
begin
  StatusBar.SimpleText := Format(SStatusLine,[ListView.Items.Count]);
end;

procedure TIBConForm.WMIBConSvcIcon(var Message: TMessage);
var
  pt: TPoint;
begin
  case Message.LParam of
    WM_RBUTTONUP:
      if not Visible then
      begin
        SetForegroundWindow(Handle);
        GetCursorPos(pt);
        PopupMenu.Popup(pt.x, pt.y);
      end
      else
        SetForegroundWindow(Handle);
    WM_LBUTTONDBLCLK:
      if Visible then
        SetForegroundWindow(Handle)
      else
        actOpen.Execute;
  end;
end;

procedure TIBConForm.Initialize(FromApp: Boolean);
begin
  FFromApp := FromApp;
  if FromApp then
    actStart.Execute
  else
  begin
    N1.Visible := False;
    actStart.Visible := False;
    actStop.Visible := False;
    actPause.Visible := False;
    actContinue.Visible := False;
    N2.Visible := False;
    actExit.Visible := False;
  end;
end;

{ TIBConService }

procedure ServiceController(CtrlCode: DWord); stdcall;
begin
  IBConService.Controller(CtrlCode);
end;

function TIBConService.GetServiceController: TServiceController;
begin
  Result := ServiceController;
end;

constructor TIBConService.CreateNew(AOwner: TComponent; Dummy: Integer);
begin
  inherited CreateNew(AOwner, Dummy);
  Interactive := True;
  DisplayName := SApplicationName;
  Name := SServiceName;
  StartType := stManual;
  OnStart := Start;
  OnStop := Stop;
  OnPause := Pause;
  OnContinue := Continue;
end;

procedure TIBConService.Start(Sender: TService; var Started: Boolean);
begin
  IBConForm.actStart.Execute;
  Started := True;
end;

procedure TIBConService.Stop(Sender: TService; var Stopped: Boolean);
begin
  IBConForm.actStop.Execute;
  PostMessage(IBConForm.Handle, WM_QUIT, 0, 0);
  Stopped := True;
end;

procedure TIBConService.Pause(Sender: TService; var Paused: Boolean);
begin
  IBConForm.actPause.Execute;
  Paused := True;
end;

procedure TIBConService.Continue(Sender: TService; var Continued: Boolean);
begin
  IBConForm.actContinue.Execute;
  Continued := True;
end;

{ TIBConThread }

procedure TIBConThread.Execute;
var
  TcpTable: TMibTcpTable;
  HostEnt: PHostEnt;
  dwSize, dwResult, i, j: DWORD;
  NewConnect: Boolean;
  FileHandle: Integer;
  LogStr: string;
begin
  while not Terminated do
  begin
    dwSize := SizeOf(TMibTcpTable);
    FillChar(TcpTable, dwSize, 0);
    dwResult := GetExtendedTcpTable(@TcpTable, @dwSize, True, AF_INET, TCP_TABLE_OWNER_PID_ALL, 0);
    if dwResult <> NO_ERROR then Continue;
    with TcpTable do
      for i := dwNumEntries - 1 downto 0 do
        if not ((table[i].dwState = MIB_TCP_STATE_ESTAB) and
          (htons(table[i].dwLocalPort) = IBPort)) then
        begin
          FillChar(table[i], SizeOf(TMibTcpRow), 0);
          Dec(dwNumEntries);
        end;
    with FIBConTable do
      if dwNumEntries <> 0 then
        for i := 0 to High(table) do
          if table[i].dwState <> 0 then table[i].dwState := MIB_TCP_STATE_CLOSED;
    with TcpTable do
      if dwNumEntries <> 0 then
        for i := 0 to High(table) do
          if table[i].dwState <> 0 then
          begin
            NewConnect := True;
            for j := 0 to High(FIBConTable.table) do
              if table[i].dwRemotePort = FIBConTable.table[j].dwRemotePort then
              begin
                NewConnect := False;
                FIBConTable.table[j].dwState := table[i].dwState;
                Break;
              end;
            if NewConnect then
              for j := 0 to High(FIBConTable.table) do
                if FIBConTable.table[j].dwState = 0 then
                begin
                  Inc(FIBConTable.dwNumEntries);
                  FIBConTable.table[j].dwState := table[i].dwState;
                  FIBConTable.table[j].dwRemoteAddr := table[i].dwRemoteAddr;
                  FIBConTable.table[j].dwRemotePort := table[i].dwRemotePort;
                  FIBConTable.table[j].MemSize := IBConForm.GetProcessMemorySize(table[i].dwowningPid);
                  HostEnt := gethostbyaddr(@table[i].dwRemoteAddr, 4, PF_INET);
                  if Assigned(HostEnt) then
                    FIBConTable.table[j].HostName := HostEnt^.h_name
                  else
                    FIBConTable.table[j].HostName := '(Unknown)';
                  FIBConTable.table[j].dtConnect := Now;
                  if not SingleLine then
                  begin
                    FileHandle := FileOpen(LogFile, fmOpenReadWrite or fmShareDenyNone);
                    if FileHandle <> -1 then
                    begin
                      LogStr := Format(SFmtStr, [ComputerName, SApplicationName,
                                                 FormatDateTime(SDTFmtStr, FIBConTable.table[j].dtConnect),
                                                 'Connect', FormatIP(FIBConTable.table[j].dwRemoteAddr),
                                                 FIBConTable.table[j].HostName]);
                      FileSeek(FileHandle, 0, 2);
                      FileWrite(FileHandle, PChar(LogStr)^, Length(LogStr));
                      FileClose(FileHandle);
                    end;
                  end;
                  FCurRow := @FIBConTable.table[j];
                  Synchronize(AddConnect);
                  Break;
                end;
          end;
    with FIBConTable do
      if dwNumEntries <> 0 then
        for i := 0 to High(table) do
          if table[i].dwState = MIB_TCP_STATE_CLOSED then
          begin
            Dec(dwNumEntries);
            table[i].dtDisconnect := Now;
            FileHandle := FileOpen(LogFile, fmOpenReadWrite or fmShareDenyNone);
            if FileHandle <> -1 then
            begin
              if SingleLine then
                LogStr := Format(SFmtSingleStr, [FormatIP(table[i].dwRemoteAddr), table[i].HostName,
                                                 FormatDateTime(SDTFmtSingleStr, table[i].dtConnect),
                                                 FormatDateTime(SDTFmtSingleStr, table[i].dtDisconnect)])
              else
                LogStr := Format(SFmtStr, [ComputerName, SApplicationName,
                                           FormatDateTime(SDTFmtStr, table[i].dtDisconnect),
                                           'Disconnect', FormatIP(table[i].dwRemoteAddr),
                                           table[i].HostName]);
              FileSeek(FileHandle, 0, 2);
              FileWrite(FileHandle, PChar(LogStr)^, Length(LogStr));
              FileClose(FileHandle);
            end;
            FCurRow := @table[i];
            Synchronize(RemoveConnect);
            FillChar(table[i], SizeOf(TIBConRow), 0);
          end;
    Sleep(TimeOut);
  end;
end;

procedure TIBConThread.AddConnect;
begin
  with IBConForm do
  begin
    with ListView.Items.Add do
    begin
      Caption := FormatIP(FCurRow^.dwRemoteAddr);
      SubItems.Add(FCurRow^.HostName);
      SubItems.Add(FormatDateTime(SDTFmtStr, FCurRow^.dtConnect));
      SubItems.Add(FCurRow^.MemSize);
      Data := FCurRow;
    end;
    UpdateStatus;
  end;
end;

procedure TIBConThread.RemoveConnect;
var
  Item: TListItem;
begin
  with IBConForm do
  begin
    Item := ListView.FindData(0, FCurRow, True, False);
    if Assigned(Item) then Item.Free;
    UpdateStatus;
  end;
end;

{ TIBFindThread }

procedure TIBFindThread.Execute;
begin
{  while not Terminated do
  begin
    if FindWindow('FB_Server', 'Firebird Server') = 0 then    begin
      if not IBConThread.Suspended then
        IBConThread.Suspend
    end
    else if IBConThread.Suspended then
      IBConThread.Resume;
    Sleep(13000);
  end; }
end;
function TIBConForm.GetProcessMemorySize(ProcessID: Integer): String;
var 
  Process: THandle; 
  MemInfo: TProcessMemoryCounters;
begin
  Process := OpenProcess(PROCESS_QUERY_INFORMATION, False, ProcessID);
  if (GetProcessMemoryInfo(Process, @MemInfo, SizeOf(MemInfo))) then
    Result := IntToStr(MemInfo.WorkingSetSize div 1024) + 'KB'
  else
    Result := '';
end;

end.