pcap.pas

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

{ Magenta Systems Internet Packet Monitoring Components

********************************************************************************
--------------------------------------------------------------------------------
                         Plibcap Highlevel function calls

                for Packet Capture Driver by Politecnico di Torino

     Code converted and modified from C to Pascal by Lars Peter Christiansen
--------------------------------------------------------------------------------
 TERMS AND CONDITIONS OF USE.
 some parts of this software is Copyright(C) 2000 Lars Peter Christiansen.

 The author of this software assumes no liability for damages caused under
 any circumstances whatsoever, and is under no obligation. Use of the software
 indicates acceptance of all conditions contained in this document. If you do
 not agree to these terms, you must delete this software immediately.

 You may distribute the archive in which this software is distributed, but
 under no circumstances must this archive be changed. Distributing a modified
 archive is a violation of the software license.

 If you do redistribute this software, please let me know at the email address
 given below.

 If you have any questions, requests, bug reports, etc., please contact me at
 the address given below.

Lars Peter Christiansen
Email  : [e-mail]
Website: http://www.nzlab.dk

Plibcap.c author:
old website: http://netgroup-serv.polito.it/windump
new website: http://www.winpcap.org/

Updated by Angus Robertson, Magenta Systems Ltd, England, 30th October 2005
[e-mail], http://www.magsys.co.uk/delphi/
Some parts Copyright Magenta Systems Ltd

--------------------------------------------------------------------------------

                          [ user application ]
                          [       PCAP       ] <- you are here!
                          [    PacketAPI     ]
            -------------------------------------------------------
            [ Windows 95/98 |  Windows NT  |  Windows2000/XP/W2K  ]
            [  Packet.dll   |  Packet.dll  |  packet.dll          ]
            [  npf.vxd      |  npf.sys     |  npf.sys             ]
            -------------------------------------------------------
                          [    Netadapter    ]


   Original Filename : Pcap.pas

   Implemented Original Functions :
      Function pcap_open_live() : PPcap
      function pcap_read()      : integer
      function pcap_stats()     : integer
      function pcap_setbuff()   : integer
      function pcap_loop()      : integer
      function pcap_datalink    : integer

   Modified/added/removed :

    30th October 2005 - Angus Robertson, Magenta Systems Ltd
                  replaced static linkage with dynamic DLL loading
                  added new winpcap website
                  fixed Pcap_GetAdapternames not returning any names for Windows 2000 and 2003,
                    now checking WinPcap version so 3.0 and 3.1 both supported transparently
                  added Pcap_GetAdapternamesEx to return both adaptor names and friendly descriptions
                  added Pcap_GetDriverVersion (3.1), Pcap_GetPacketVersion
                  added Pcap_GetIPAddresses to get adapter IP addresses
                  added Pcap_SetMinToCopy (3.1)
                  pcap_open_live tries to set SnapLen (3.1)
                  added Pcap_GetMacAddress, useful to see if packets are being sent or received
                  tested with 3.1 final release 5th August 2005

    25-05-2005:
      Seems WinPcap 3.1 returns 8-bit adapternames in XP. issue fixed

    17-1-2002:
      Pcap_loop() : Fixed silly bug not exiting endless loop
      pcap_getwinversion(): updated to include WinXP and WinME

    28-1-2001:
      Function Pcap_GetAdapternames() : bug found&fixed [ by _blade_ ]
      Function Pcap_Read() : fixed wrong headerpos in packets. [Jody Dawkins]

     4-2-2000:
      Function Pcap_close  : now removing pcap.buffer from memory
    Older:
      function wsockinit()      : integer; // Removed. obsolete in Delphi
      function  pcap_lookupdev(): pchar;   // Modified to Delphi's advantage
      function pcap_getwinversion: Twinversion // added. Much easier OS handling
      function Pcap_getAdapternames() : String // Hand in hand with Tlist.commatext


   Wanted :
      function pcap_GetMACAddr()  : boolean;
      function pcap_open_offline  : PPcap; + offline functions

********************************************************************************
}

unit Pcap;

interface
uses windows,
     Ndis_def,
     bpf,
     sysutils,  // formatting tools. Could use FormatMessage,but is more complex
     classes,
     winsock, 
     Packet32;  // This is what we wrap

const
  PCAP_ERRBUF_SIZE = 256;              //String size of error descriptions
  PcapBufSize      = 256000;           //Dimension of the buffer in TPcap


// [taken from interface.h]

  DEFAULT_SNAPLEN = 68;                //The default snapshot length.
                                       //This value allows most printers to
                                       //print useful information while keeping
                                       //the amount of unwanted data down.In
                                       //particular, it allows for an ethernet
                                       //header, tcp/ip header, and 14 bytes of
                                       //data (assuming no ip options).


type
  TWinVersion = (wv_WinS,
                 wv_Win9x,              //Added by Lars Peter Christiansen.
                 wv_WinNT,              //Eases the process of determing the
                 wv_Win2000,             //platform and do proper instructions
                 wv_WinXP,               //I.e : Char vs. WideChar issue
                 wv_Unknown );



  PPcap_Stat = ^TPcap_stat;
  Tpcap_stat = record
    ps_recv,	                 	 //* number of packets received */
    ps_drop,	                	 //* number of packets dropped */
    ps_ifdrop : LongWord;                //* drops by interface not supported */
  end;

  TPcap_sf = record                      // Save file for offline reading.
    rfile : HFILE;
    swapped:integer;
    version_major : integer;
    Version_Minor : integer;
    base : Pointer;
  end;

  TPcap_md = record
    Stat : TPcap_stat;
    use_bpf : integer;
    TotPkts  : LongWord;               // Can owerflow after 79hours on ethernet
    TotAccepted:LongWord;              // accepted by filter/sniffer
    TotDrops : LongWord;               // dropped packets
    TotMissed: Longword;               // missed by i/f during this run
    OrigMissed:LongWord;               // missed by i/f before this run
  end;

  PPcap_PktHdr = ^Tpcap_pkthdr;        // Wrapped Drivers packetHeader
  TPcap_pkthdr = record
    ts     : TUnixTimeVal;             // Time of capture
    CapLen,                            // captured length
    Len    : Integer;                  // actual length of packet
  end;

  PPcap = ^TPcap;                      // THE MAIN INTERFACE HANDLE
  TPcap = record                       // used with allmost all Pcap calls.
    Adapter:Padapter;
    Packet :PPacket;                   // Global Driver packet. kind of a buffer
    snapshot:integer;
    linktype:integer;                  // Type and speed of net
    tzoff   :integer;	               // timezone offset
    offset  :integer;
    sf      :Tpcap_sf;                 // Save file
    md      :Tpcap_md;                 // Diagnostics
    //READ BUFFER
    bufsize :integer;
    buffer  :Pointer; //*u_char
    bp      :Pointer; //*u_char
    cc      :integer;
    //Place holder for pcap_next().
    pkt     :Pointer; //*U_char
    //Placeholder for filter code if bpf not in kernel.
    fcode   :Tbpf_program;
    errbuf  : array [0..PCAP_ERRBUF_SIZE-1] of char;  //Last error message
  end;


  // Callback procedure
  Ppcap_handler =^Tpcap_handler;
  Tpcap_handler = procedure(User:pointer;const Header:Ppcap_pkthdr;const Data:pchar);

  // array of IP addresses
  IPAddrArray = array of TInAddr ;

  // a MAC address
  TMacAddr = array [0..5] of byte ;

function  pcap_open_live(Device:String;SnapLen:LongWord;Promisc:boolean;
          To_ms:integer;var errstr:String) : ppcap;
function  pcap_read(p:PPcap;cnt:integer;CallBack:Tpcap_handler;User:pointer) :integer;
function  pcap_stats    (P: pPcap;ps:PPcap_stat) : integer;
function  pcap_setbuff  (p : Ppcap;dim:integer) : integer;
procedure pcap_close    (var p : ppcap);
function  pcap_lookupdev(var ErrStr:string) : pchar;
function pcap_loop(P:Ppcap;cnt:integer;Callback:Tpcap_handler;user:pointer):integer;
function pcap_datalink(P:PPcap) : integer;
function pcap_getwinversion(var verstr:string) : Twinversion;
function Pcap_getAdapternames(Delimiter:char;var ErrStr:string):string;
function Pcap_GetAdapternamesEx (NameList, DescList: TStringList; var ErrStr:string):integer;
function Pcap_GetDriverVersion: string ;
function Pcap_GetPacketVersion: string ;
function Pcap_GetIPAddresses (AdapterName: string ; var IPArray, MaskArray,
                                BcastArray: IPAddrArray; var ErrStr:string): integer ;
function Pcap_SetMinToCopy (P: pPcap ; nbytes: integer) : integer;
function Pcap_GetMacAddress (P: pPcap; var ErrStr:string): TMacAddr ;

implementation


//------------------------------------------------------------------------------
//  pcap_t *pcap_open_live(char *device, int snaplen, int promisc,
//                         int to_ms, char *ebuf)
//------------------------------------------------------------------------------
function pcap_open_live(Device:String;SnapLen:LongWord;Promisc:boolean;
         To_ms:integer;var errstr:String) : ppcap;
  var
     P : Ppcap;
     NetType : Tnet_type;
     S : Pchar;

     procedure CleanUp;
     begin
       if P.adapter<>nil then PacketCloseAdapter(P.adapter);
       if P.buffer<>nil then FreeMem(P.buffer,PcapBufSize);
       Freemem(P,SizeOf(Tpcap));

     end;
begin
    result :=nil;
    if NOT LoadPacketDll then
      begin
        ErrStr := 'Cannot load packet.dll';
        exit;
      end;

    // CREATE PCAP OBJECT

    GetMem(P,SizeOf(Tpcap));
    if P=nil then
      begin
        ErrStr := 'Cannot allocate pcap object';
        exit;
      end;
    FillChar(p^,sizeof(Tpcap),0);
    P.Adapter := nil;

    // CREATE ADAPTER OBJECT
    GetMem(S,2048);                       // Making temporary pchar
    StrPCopy(S,Device);
    P.Adapter := PacketOpenAdapter(S);
    FreeMem(S,2048);
    if P.Adapter = nil then
      begin
        ErrStr := 'Cannot Open Adapter "'+Device+'"';
        CleanUp;
        exit;
      end;


   // SET FILTER MODE
    if Promisc then
      begin
        if not PacketSetHWFilter(P.adapter,NDIS_PACKET_TYPE_PROMISCUOUS) then
          Begin
            ErrStr:= 'Cannot set Device Filter to Promiscuous mode';
            cleanup;
            exit;
          end;
      end else if not PacketSetHWFilter(P.adapter,NDIS_PACKET_TYPE_DIRECTED) then
          begin
            ErrStr:= 'Cannot set Device Filter to Directed mode';
            cleanup;
            exit;
          end;

    // GET NETCARD SPEED AND TYPE
    if not PacketGetNetType(P.Adapter,@Nettype) then
       Begin
         ErrStr := 'Cannot determine network type and speed';
         Cleanup;
         exit;
       end;

    Case TNDIS_MEDIUM(nettype.LinkType) of

       NdisMediumWan   : P.linktype := DLT_PPP_WIN32;

       NdisMedium802_3 : begin
                           if nettype.LinkSpeed = 100000000 then
                              p.linktype := DLT_EN100MB
                           else if nettype.LinkSpeed=10000000 then
                              p.linktype := DLT_EN10MB
                           else p.linktype:=DLT_PPP_WIN32;
                         end;
       else p.linktype := DLT_EN10MB;
    end;

    // Allocate room for Link header

    p.bufsize := PcapBufSize;
    GetMem(p.buffer,PcapBufSize);
    if P.buffer = nil then
      begin
        ErrStr := 'Cannot allocate Link Header space';
        cleanup;
        exit;
      end;

    if Assigned (PacketSetSnapLen) then
        p.snapshot := PacketSetSnapLen(P.adapter, Snaplen)     // Angus - added, actually set it for 3.1 
    else
        p.snapshot := Snaplen ; 

    // Allocate Global Packet for capturing

    p.packet := PacketAllocatePacket;
    if p.packet = nil then
      begin
        ErrStr := 'Cannot allocate Global Packet Object';
        cleanup;
        exit;
      end;
    PacketInitPacket(p.Packet,p.buffer,p.bufsize);

    // Allocate Driver Buffer
    if not PacketSetBuff(p.adapter,DEFAULT_DRIVERBUFFER) then
      begin
        ErrStr := 'Not enough memory to allocate Driver buffer';
        CleanUp;
        exit;
      end;

    result := p;