monpcap.pas

Magenta Systems Internet Packet Monitoring Components are a set of Delphi components designed to cap

unit monpcap;

{ Magenta Systems Internet Packet Monitoring Components

Magenta Systems Monitor WinPCAP Component.
Updated by Angus Robertson, Magenta Systems Ltd, England, v1.1 31st October 2005
[e-mail], http://www.magsys.co.uk/delphi/
Copyright Magenta Systems Ltd

This module requires the WinPcap (windows packet library) device driver package
to installed, from http://www.winpcap.org/.  It has been tested on Windows 2000,
XP and 2003, it may work on Windows 9x but is untested.
Use of the latest WinPcap version 3.1 5th August 2005 is strongly recommended,
but the component also supports WinPcap 3.0 10 February 2003.

WinPcap for NT4 and later comprises packet.dll, wanpacket.dll, wpcap.dll. npf.sys.

The Delphi conversion for packet.dll in pcap.pas and packet32 is by Lars Peter
Christiansen, http://www.nzlab.dk, but modified by Magenta Systems from static
linkage to dynamic DLL loading to allow the application to load without the DLL
and to fix problems reading the adaptor list 



}

interface

uses
  Windows, Messages, Classes, SysUtils, Packhdrs, Winsock, Pcap, Packet32, Bpf,
  MagClasses ;

type

  TPcapThread = class ;  // forward declaration 

  TMonitorPcap = class(TComponent)
  protected
      FLastError: string ;
      FAddr: string ;
      FAddrMask: string ;
      FIgnoreIPList: TFindList ;
      FInAddr: TInAddr ;
      FInAddrMask: TInAddr ;
      FIgnoreData: boolean ;
      FIgnoreLAN: boolean ;
      FIgnoreNonIP: boolean ;
      FPromiscuous: boolean ;
      FTotRecvBytes: int64 ;
      FTotSendBytes: int64 ;
      FTotRecvPackets: integer ;
      FTotSendPackets: integer ;
      FDriverVersion: string ;
      FPacketVersion: string ;
      FOnPacketEvent: TPacketEvent ;
//      FPcapHandle: PPCAP ;        // control record handle
      FPcapThread: TPcapThread ;  // read packet thread
      FAdapterNameList: TStringList;  // ethernet adapters internal names
      FAdapterDescList: TStringList;  // ethernet adapters descriptions
      FMonAdapter: string ;       // adapter to monitor
      FConnected: boolean ;       // are we connected to PCap driver
      FAdapterMac: TMacAddr ;
      FLocalBiasUTC: TDateTime ;
      function GetAdapters: boolean ;
      procedure ThreadTerminate (Sender: TObject);
      procedure MonDataAvailable (const Header: Ppcap_pkthdr ; const PackPtr: Pchar) ;
  public
      FPcapHandle: PPCAP ;        // control record handle
      constructor Create(AOwner: TComponent); override;
      destructor  Destroy; override;
      procedure StartMonitor;
      procedure StopMonitor;
      procedure SetIgnoreIP (IPAddr: string) ;
      procedure ClearIgnoreIP ;
      function GetIPAddresses (AdapterName: string ;
                                IPList, MaskList, BcastList: TStringList): integer ;
  published
      property AdapterNameList: TStringList read FAdapterNameList ;
      property AdapterDescList: TStringList read FAdapterDescList ;
      property DriverVersion: string    read FDriverVersion ;
      property PacketVersion: string    read FPacketVersion ;
      property MonAdapter: string       read FMonAdapter
                                        write FMonAdapter ;
      property Connected: boolean       read FConnected ;
      property LastError: string        read FLastError ;
      property Addr: string             read FAddr
                                        write FAddr ;
      property AddrMask: string         read FAddrMask
                                        write FAddrMask ;
      property IgnoreData: boolean      read FIgnoreData
                                        write FIgnoreData ;
      property IgnoreLAN: boolean       read FIgnoreLAN
                                        write FIgnoreLAN ;
      property IgnoreNonIP: boolean     read FIgnoreNonIP
                                        write FIgnoreNonIP ;
      property Promiscuous: boolean     read FPromiscuous
                                        write FPromiscuous ;
      property TotRecvBytes: int64      read FTotRecvBytes ;
      property TotSendBytes: int64      read FTotSendBytes ;
      property TotRecvPackets: integer  read FTotRecvPackets ;
      property TotSendPackets: integer  read FTotSendPackets ;
      property OnPacketEvent: TPacketEvent read  FOnPacketEvent
                                           write FOnPacketEvent;
  end;

  TPcapThread = class(TThread)
  private
      FMonitorPcap: TMonitorPcap ;
      procedure GetPackets ;
  public
      procedure Execute; override;
  end;

implementation

procedure Register;
begin
    RegisterComponents('FPiette', [TMonitorPcap]) ;
end ;

function GetLocalBiasUTC: Integer;
var
    tzInfo : TTimeZoneInformation;
begin
    case GetTimeZoneInformation(tzInfo) of
    TIME_ZONE_ID_STANDARD: Result := tzInfo.Bias + tzInfo.StandardBias;
    TIME_ZONE_ID_DAYLIGHT: Result := tzInfo.Bias + tzInfo.DaylightBias;
    else
        Result := tzInfo.Bias;
    end;
end;

procedure CaptureCallBack (User: Pointer; const Header: Ppcap_pkthdr ; const PackPtr: Pchar) ;
begin
    TPcapThread (User).FMonitorPcap.MonDataAvailable (Header, PackPtr) ;
end ;

procedure TPcapThread.GetPackets ;
begin
    Pcap_Read (FMonitorPcap.FPcapHandle, 0, CaptureCallBack, Pointer (Self)) ;
end ;

procedure TPcapThread.Execute;
begin
    if NOT Assigned (FMonitorPcap) then exit ;
    if FMonitorPcap.FPcapHandle = Nil then exit ;
    PacketSetReadTimeout (FMonitorPcap.FPcapHandle.Adapter, 100) ;
    while NOT Terminated do
    begin
        GetPackets ;
    end;
end ;

procedure TMonitorPcap.ThreadTerminate (Sender: tobject);
begin
    FConnected := false ;
    Pcap_Close (FPcapHandle) ;
    FPcapHandle := Nil ;
end;

constructor TMonitorPcap.Create(AOwner: TComponent);
begin
    FIgnoreData := false ;
    FIgnoreIPList := TFindList.Create ;
    FIgnoreIPList.Sorted := true ;
    FAdapterDescList := TStringList.Create ;
    FAdapterNameList := TStringList.Create ;
    FLastError := '' ;
    FPcapHandle := Nil ;
    FConnected := false ;
    FDriverVersion := Pcap_GetDriverVersion ;
    FPacketVersion := Pcap_GetPacketVersion ;
    GetAdapters ;
    if FAdapterNameList.Count <> 0 then FMonAdapter := FAdapterNameList [0] ;
    inherited Create(AOwner);
end ;

destructor TMonitorPcap.Destroy;
begin
    if FConnected then StopMonitor ;
    FreeAndNil (FIgnoreIPList) ;
    FreeAndNil (FAdapterNameList) ;
    FreeAndNil (FAdapterDescList) ;
    inherited Destroy;
end ;

function TMonitorPcap.GetAdapters: boolean ;
var
    total: integer ;
begin
    result := false;
    if NOT Assigned (FAdapterNameList) then exit ;
    FAdapterNameList.Clear ;
    FAdapterDescList.Clear ;
    total := Pcap.pcap_GetAdapterNamesEx (FAdapterNameList, FAdapterDescList, FLastError) ;
    if total = 0 then exit ;
    result := true;
end ;

function TMonitorPcap.GetIPAddresses (AdapterName: string ;
                                    IPList, MaskList, BcastList: TStringList): integer ;
var
    IPArray, MaskArray, BcastArray: IPAddrArray ;
    I: integer ;
begin
    IPList.Clear ;
    MaskList.Clear ;
    BcastList.Clear ;
    result := Pcap_GetIPAddresses (AdapterName, IPArray, MaskArray, BcastArray, FLastError) ;
    if result = 0 then exit ;
    for I := 0 to Pred (result) do
    begin
        IPList.Add (IPToStr (IPArray [I])) ;
        MaskList.Add (IPToStr (MaskArray [I])) ;
        BcastList.Add (IPToStr (BcastArray [I])) ;
    end ;
end ;

// called by TFindList for sort and find comparison of file records

function CompareFNext (Item1, Item2: Pointer): Integer;
// Compare returns < 0 if Item1 is less than Item2, 0 if they are equal
// and > 0 if Item1 is greater than Item2.
begin
    result := 0 ;
    if longword (Item1) > longword (Item2) then result := 1 ;
    if longword (Item1) < longword (Item2) then result := -1 ;
end ;

procedure TMonitorPcap.SetIgnoreIP (IPAddr: string) ;
var
    InIPAddr: TInAddr ;