netstat.dpr

IPHlpAPI delphi源码

{******************************************************************}
{                                                                  }
{       NetStat.dpr - IP Helper API Demonstration project          }
{                                                                  }
{ Portions created by Marcel van Brakel are                        }
{ Copyright (C) 2000 Marcel van Brakel.                            }
{ All Rights Reserved.                                             }
{                                                                  }
{ The original file is: NetStat.dpr, released  December 2000.      }
{ The initial developer of the Pascal code is Marcel van Brakel    }
{ ([e-mail]).                                             }
{ 								   }
{ Contributor(s):  Vladimir Vassiliev ([e-mail])       }
{                  John Penman ([e-mail])             }
{                                                                  }
{ Obtained through:                                                }
{ Joint Endeavour of Delphi Innovators (Project JEDI)              }
{                                                                  }
{ You may retrieve the latest version of this file at the Project  }
{ JEDI home page, located at http://delphi-jedi.org.               }
{                                                                  }
{ The contents of this file are used with permission, subject to   }
{ the Mozilla Public License Version 1.1 (the "License"); you may  }
{ not use this file except in compliance with the License. You may }
{ obtain a copy of the License at                                  }
{ http://www.mozilla.org/NPL/NPL-1_1Final.html                     }
{                                                                  }
{ Software distributed under the License is distributed on an      }
{ "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or   }
{ implied. See the License for the specific language governing     }
{ rights and limitations under the License.                        }
{                                                                  }
{******************************************************************}

program NetStat;

{$APPTYPE CONSOLE}

uses
  Windows, SysUtils, Winsock,
  IpExport, IpHlpApi, IpTypes, IpIfConst, IpRtrMib;

//------------------------------------------------------------------------------

function UintToYesNo(U: UINT): string;
begin
  if U = 0 then
    Result := 'No'
  else
    Result := 'Yes';
end;

//------------------------------------------------------------------------------

function BooleanToYesNo(B: Boolean): string;
begin
  if B then
    Result := 'Yes'
  else
    Result := 'No';
end;

//------------------------------------------------------------------------------

// Converts a PIpAddrString to a string which includes both the IP address as
// well as the subnet mask in the form <ip addr>/<subnet mask>

function IpAddrStringToString(IpAddr: PIpAddrString): string;
begin
  Result := '';
  if IpAddr <> nil then
  begin
    Result := IpAddr^.IpAddress.S;
    if IpAddr.IpMask.S <> '' then Result := Result + '/' + IpAddr.IpMask.S
  end;
end;

//------------------------------------------------------------------------------

// Returns the name of the computer in lowercase, used by IpAddrToString. Simpy
// a convenience wrapper which avoids having to deal with buffer management in
// the routines that require the computer name

function GetLocalComputerName: string;
var
  Size: DWORD;
begin
  Size := 1024;
  SetLength(Result, Size);
  GetComputerName(PChar(Result), Size);
  SetLength(Result, StrLen(PChar(Result)));
  Result := LowerCase(Result);
end;

//------------------------------------------------------------------------------

var
  // Determines whether IpAddrToString() resolves IP addresses to names. By
  // default it does but can be set to False using the -n switch
  ResolveNames: Boolean = True;

//------------------------------------------------------------------------------

// Convert IP address to dotted decimal without port or name resolving

function IpAddrToString(Addr: DWORD): string; overload;
var
  inad: in_addr;
begin
  inad.s_addr := Addr;
  Result := inet_ntoa(inad);
end;

//------------------------------------------------------------------------------

// Convert the specified IP address to a dotted decimal string representation
// and suffixes it with the specified port. If ResolveNames is True, the
// function attempts to translate the IP address to a host name and the port to
// a service name. If local is true the IP address is translated to the name of
// the local machine but port is not translated (doesn't work for remote machines)

function IpAddrToString(Addr, Port: DWORD; Local: Boolean): string; overload;
var
  inad: in_addr;
  HostEnt: PHostEnt;
  ServEnt: PServEnt;
begin
  inad.s_addr := Addr;
  Result := inet_ntoa(inad);
  // If user wants names instead of IP addresses
  if ResolveNames then
  begin
    if Local or (Addr = 0) then
    begin
      ServEnt := GetServByPort(Port, nil);
      if ServEnt <> nil then
        Result := GetLocalComputerName + ':' + ServEnt^.s_name + '(' + ServEnt^.s_proto + ')'
      else
        Result := GetLocalComputerName + ':' + IntToStr(htons(Port));
    end
    else
    begin
      HostEnt := GetHostByAddr(PChar(@Addr), SizeOf(DWORD), AF_INET);
      if HostEnt <> nil then
        Result := HostEnt^.h_name + ':' + IntToStr(htons(Port))
      else
        Result := Result + ':' + IntToStr(htons(Port));
    end;
  end;
end;

//------------------------------------------------------------------------------

// Returns a string representation for the specified TCP connection state value

function TcpStateString(State: DWORD): string;
begin
  case State of
    MIB_TCP_STATE_CLOSED:    Result := 'Closed';
    MIB_TCP_STATE_LISTEN:    Result := 'Listening';
    MIB_TCP_STATE_SYN_SENT:  Result := 'Syn sent';
    MIB_TCP_STATE_SYN_RCVD:  Result := 'Syn received';
    MIB_TCP_STATE_ESTAB:     Result := 'Established';
    MIB_TCP_STATE_FIN_WAIT1: Result := 'Fin wait1';
    MIB_TCP_STATE_FIN_WAIT2: Result := 'Fin wait2';
    MIB_TCP_STATE_CLOSE_WAIT:Result := 'Close wait';
    MIB_TCP_STATE_CLOSING:   Result := 'Closing';
    MIB_TCP_STATE_LAST_ACK:  Result := 'Last ack';
    MIB_TCP_STATE_TIME_WAIT: Result := 'Time wait';
    MIB_TCP_STATE_DELETE_TCB:Result := 'Delete TCB';
  else
    Result := 'Unknown';
  end;
end;

//------------------------------------------------------------------------------

// Displays the TCP connection table (TCP connections)

procedure DisplayTcpConnections;
var
  Size: ULONG;
  TcpTable: PMibTcpTable;
  TcpRow: TMibTcpRow;
  I: Integer;
begin
  Size := 0;
  if GetTcpTable(nil, Size, True) <> ERROR_BUFFER_OVERFLOW then Exit;
  TcpTable := AllocMem(Size);
  try
    if GetTcpTable(TcpTable, Size, True) = NO_ERROR then
    begin
      for I := 0 to TcpTable^.dwNumEntries - 1 do
      begin
        {$R-}TcpRow := TcpTable^.Table[I];{$R+}
        WriteLn(Format('  %-5s  %-25s  %-25s  %-s',
         ['TCP',
          IpAddrToString(TcpRow.dwLocalAddr, TcpRow.dwLocalPort, True),
          IpAddrToString(TcpRow.dwRemoteAddr, TcpRow.dwRemotePort, False),
          TcpStateString(TcpRow.dwState)]));
      end;
    end;
  finally
    FreeMem(TcpTable);
  end;
end;

//------------------------------------------------------------------------------

// Displays the UDP listener table (UDP "connections")

procedure DisplayUdpConnections;
var
  Size: ULONG;
  I: Integer;
  UdpTable: PMibUdpTable;
  UdpRow: TMibUdpRow;
begin
  Size := 0;
  if GetUdpTable(nil, Size, True) <> ERROR_BUFFER_OVERFLOW then Exit;
  UdpTable := AllocMem(Size);
  try
    if GetUdpTable(UdpTable, Size, True) = NO_ERROR then
    begin
      for I := 0 to UdpTable.dwNumEntries - 1 do
      begin
        {$R-}UdpRow := UdpTable.Table[I];{$R+}
        WriteLn(Format('  %-5s  %-25s  %-25s  %-s', 
         ['UDP',
          IpAddrToString(UdpRow.dwLocalAddr, UdpRow.dwLocalPort, True),
          '*.*',
          '']));
      end;
    end;
  finally
    FreeMem(UdpTable);
  end;
end;

//------------------------------------------------------------------------------

// Displays active connections for the specified protocol. Protocol can be
// either TCP, UDP or an empty string. In the latter case connections for both
// the protocols are displayed.

procedure DisplayConnections(const Protocol: string);
begin
  WriteLn('Active connections');
  WriteLn;
  WriteLn('  Proto  Local address              Foreign address            State');
  if Protocol = '' then
  begin
    DisplayTcpConnections;
    DisplayUdpConnections;
  end
  else if Protocol = 'TCP' then
    DisplayTcpConnections
  else if Protocol = 'UDP' then
    DisplayUdpConnections;
end;

//------------------------------------------------------------------------------

// Displays statistics for the IP protocol

procedure DisplayIpStatistics;
var
  IpStats: TMibIpStats;
begin
  if GetIpStatistics(IpStats) = NO_ERROR then
  begin
    WriteLn('IP Statistics');
    WriteLn('');
    WriteLn('  IP forwarding enabled. . . . . . . : ' + UintToYesNo(IpStats.dwForwarding));
    WriteLn('  Default TTL. . . . . . . . . . . . : ' + IntToStr(IpStats.dwDefaultTTL));
    WriteLn('  Received datagrams . . . . . . . . : ' + IntToStr(IpStats.dwInReceives));
    WriteLn('  Datagrams with header errors . . . : ' + IntToStr(IpStats.dwInHdrErrors));
    WriteLn('  Datagrams with address errors. . . : ' + IntToStr(IpStats.dwInAddrErrors));
    WriteLn('  Forwarded datagrams. . . . . . . . : ' + IntToStr(IpStats.dwForwDatagrams));
    WriteLn('  Unknown protocol datagrams . . . . : ' + IntToStr(IpStats.dwInUnknownProtos));
    WriteLn('  Discarded datagrams. . . . . . . . : ' + IntToStr(IpStats.dwInDiscards));
    WriteLn('  Delivered datagrams. . . . . . . . : ' + IntToStr(IpStats.dwInDelivers));
    WriteLn('  Outgoing datagram requests . . . . : ' + IntToStr(IpStats.dwOutRequests));
    WriteLn('  Discarded outgoing datagrams . . . : ' + IntToStr(IpStats.dwRoutingDiscards));
    WriteLn('  Discarded outgoing datagrams . . . : ' + IntToStr(IpStats.dwOutDiscards));
    WriteLn('  Discarded due to no route. . . . . : ' + IntToStr(IpStats.dwOutNoRoutes));
    WriteLn('  Reassemby timeout. . . . . . . . . : ' + IntToStr(IpStats.dwReasmTimeout));
    WriteLn('  Reassembly required datagrams. . . : ' + IntToStr(IpStats.dwReasmReqds));
    WriteLn('  Successfully reassembled datagrams : ' + IntToStr(IpStats.dwReasmOks));
    WriteLn('  Failed reassembled datagrams . . . : ' + IntToStr(IpStats.dwReasmFails));
    WriteLn('  Succesfully fragmented datagrams . : ' + IntToStr(IpStats.dwFragOks));
    WriteLn('  Failed fragmented datagrams. . . . : ' + IntToStr(IpStats.dwFragFails));
    WriteLn('  Fragments created. . . . . . . . . : ' + IntToStr(IpStats.dwFragCreates));
    WriteLn('  Number of interfaces . . . . . . . : ' + IntToStr(IpStats.dwNumIf));
    WriteLn('  Number of IP addresses . . . . . . : ' + IntToStr(IpStats.dwNumAddr));
    WriteLn('  Number of routes . . . . . . . . . : ' + IntToStr(IpStats.dwNumRoutes));
    WriteLn('');
  end;
end;

//------------------------------------------------------------------------------

// Displays statistics for the TCP protocol

procedure DisplayTcpStatistics;
var
  TcpStats: TMibTcpStats;
begin
  if GetTcpStatistics(TcpStats) = NO_ERROR then
  begin
    WriteLn('TCP Statistics');
    WriteLn;
    case TcpStats.dwRtoAlgorithm of
      MIB_TCP_RTO_OTHER:  WriteLn('  RTO algorithm. . . . . . . . . . . . : Other');
      MIB_TCP_RTO_CONSTANT: WriteLn('  RTO algorithm. . . . . . . . . . . . : Constant time-out');
      MIB_TCP_RTO_RSRE: WriteLn('  RTO algorithm. . . . . . . . . . . . : MIL-STD-1778 Appendix B');
      MIB_TCP_RTO_VANJ: WriteLn('  RTO algorithm. . . . . . . . . . . . : Van Jacobson''s Algorithm');
    end;
    WriteLn('  Minimum retransmission time-out. . . : ' + IntToStr(TcpStats.dwRtoMin));
    WriteLn('  Maximum retransmission time-out. . . : ' + IntToStr(TcpStats.dwRtoMax));
    WriteLn('  Maximum number of connections. . . . : ' + IntToStr(TcpStats.dwMaxConn));
    WriteLn('  Active opens . . . . . . . . . . . . : ' + IntToStr(TcpStats.dwActiveOpens));
    WriteLn('  Passive opens. . . . . . . . . . . . : ' + IntToStr(TcpStats.dwPassiveOpens));
    WriteLn('  Failed connection attempts . . . . . : ' + IntToStr(TcpStats.dwAttemptFails));
    WriteLn('  Reset established connections. . . . : ' + IntToStr(TcpStats.dwEstabResets));
    WriteLn('  Established connections. . . . . . . : ' + IntToStr(TcpStats.dwCurrEstab));
    WriteLn('  Received segments. . . . . . . . . . : ' + IntToStr(TcpStats.dwInSegs));
    WriteLn('  Transmitted segments . . . . . . . . : ' + IntToStr(TcpStats.dwOutSegs));
    WriteLn('  Retransmitted segments . . . . . . . : ' + IntToStr(TcpStats.dwRetransSegs));
    WriteLn('  Received errors. . . . . . . . . . . : ' + IntToStr(TcpStats.dwInErrs));
    WriteLn('  Transmitted segments with reset flag : ' + IntToStr(TcpStats.dwOutRsts));
    WriteLn('  Cumulative number of connections . . : ' + IntToStr(TcpStats.dwNumConns));
  end;
  WriteLn;
end;

//------------------------------------------------------------------------------

// Displays statistics for the ICMP protocol

procedure DisplayIcmpStatistics;
var
  Icmp: TMibIcmp;

  procedure DisplayStats(const Stats: TMibIcmpStats);
  begin
    WriteLn('  Messages. . . . . . . . : ' + IntToStr(Stats.dwMsgs));
    WriteLn('  Errors. . . . . . . . . : ' + IntToStr(Stats.dwErrors));
    WriteLn('  Destination unreachable : ' + IntToStr(Stats.dwDestUnreachs));
    WriteLn('  Time-to-live exceeded . : ' + IntToStr(Stats.dwTimeExcds));
    WriteLn('  Parameter problems. . . : ' + IntToStr(Stats.dwParmProbs));
    WriteLn('  Source quench . . . . . : ' + IntToStr(Stats.dwSrcQuenchs));
    WriteLn('  Redirection . . . . . . : ' + IntToStr(Stats.dwRedirects));
    WriteLn('  Echo requests . . . . . : ' + IntToStr(Stats.dwEchos));
    WriteLn('  Echo replies. . . . . . : ' + IntToStr(Stats.dwEchoReps));
    WriteLn('  Time-stamp requests . . : ' + IntToStr(Stats.dwTimestamps));
    WriteLn('  Time-stamp replies. . . : ' + IntToStr(Stats.dwTimestampReps));
    WriteLn('  Address-mask requests . : ' + IntToStr(Stats.dwAddrMasks));
    WriteLn('  Address-mask replies. . : ' + IntToStr(Stats.dwAddrMaskReps));
  end;