testapp.pl

• package main
  • printPackets
• EOF

#!/usr/bin/perl -w
# ---------------------------------------------------------
# testapp.pl (v 0.2): captures and dump packets;
# based on Loris Degioanni's TestApp program in C
# (see the Packet Capture Driver Developer's Pack).
# This simple example shows how to capture raw packets
# to the network using Win32::NetPacket.
# This program is free software; you can redistribute it
# and/or modify it under the same terms as Perl itself.
# (c) 2003-2006 J-L Morel jlmorel@cpan.org
# ---------------------------------------------------------

use strict;
use Win32::Console::ANSI;
use Win32::NetPacket qw/ :ndis GetAdapterNames  /;
use Term::ReadKey;
$|++;

use constant SizeOfInt => 4;    # for word alignment

# select the adapter
my %desc;
my @adpts = GetAdapterNames( \%desc );
@adpts > 0 or die "No adapter installed !\n";
my $i = 1;
if ( @adpts > 1 ) {
  print "Adapters installed:\n\n";
  print $i++, " - $desc{$_}\n    $_\n" foreach @adpts;
  do {
    print "\nSelect the number of the adapter to open : ";
    $i = <STDIN>;
    chomp $i;
  } until ( $i =~ /^(\d)+$/ and 0 < $i and $i <= @adpts );
}

# open the selected adapter
my $nic = Win32::NetPacket->new(
  adapter_name       => $adpts[ $i - 1 ],
  driver_buffer_size => 512 * 1024,         # 512 kbytes kernel buffer
  read_timeout       => 1000,               # 1s timeout
) or die $@;

$nic->SetHwFilter(NDIS_PACKET_TYPE_PROMISCUOUS); # set nic in promiscuous mode

# print infos
my ( $name, $description, $type, $speed, $ip, $mask, $mac ) = $nic->GetInfo();
$description ||= $desc{$name};
$ip          ||= '?.?.?.?';
$mask        ||= '?.?.?.?';
$mac = join '-', unpack 'A2' x 6, $mac;
print "Listening $name\n($description)\nMAC: $mac IP: $ip Mask: $mask\n";
print "** press [enter] to terminate\n";

# set user's buffer
my $Buff;
$nic->SetUserBuffer( $Buff, 128 * 1024 );

# main capture loop
my $BytesReceived;
while ( !ReadKey(-1) ) {    # press (enter) to terminate
  $BytesReceived = $nic->ReceivePacket();    # capture the packets
  printPackets();                            # print the packets
}

printf "\n\n%d packets received,\n%d packets lost.\n", $nic->GetStats;

# ------ printPackets routine

sub printPackets {
  my $nic    = shift;
  my $offset = 0;
  while ( $offset < $BytesReceived ) {
    my ( $tv_sec, $tv_usec, $caplen, $datalen, $hdrlen ) = unpack 'llIIS',
      substr $Buff, $offset;
    printf "\nPacket length, captured portion: %ld, %ld\n", $datalen, $caplen;
    $offset += $hdrlen;
    my $data = substr $Buff, $offset, $datalen;    # extract the datagram
    my $i = 0;
    do {
      local $, = ' ';
      my $lg = substr $data, $i, 16;
      printf "%.8X : ", $i;
      $i += 16;
      print unpack( 'H2' x 16, $lg ), '  ' x ( 16 - length $lg );
      $lg =~ s/[\x00-\x1F\x95\xFF]/./g;
      print " $lg\n";
    } until $i >= $datalen;

    # Packet word alignment
    $offset
      = ( ( $offset + $caplen ) + ( SizeOfInt - 1 ) ) & ~( SizeOfInt - 1 );
  }
}