File Coverage

blib/lib/Net/Pcap/Easy.pm
Criterion Covered Total %
statement 13 15 86.6
branch n/a
condition n/a
subroutine 5 5 100.0
pod n/a
total 18 20 90.0


line stmt bran cond sub pod time code
1              
2             package Net::Pcap::Easy;
3              
4 13     13   9996 use strict;
  13         22  
  13         436  
5 13     13   52 no warnings;
  13         17  
  13         440  
6              
7 13     13   62 use Carp;
  13         12  
  13         866  
8 13     13   8325 use Socket;
  13         44246  
  13         6340  
9 13     13   11863 use Net::Pcap;
  0            
  0            
10             use Net::Netmask;
11             use NetPacket::Ethernet qw(:types);
12             use NetPacket::IP qw(:protos);
13             use NetPacket::ARP qw(:opcodes);
14             use NetPacket::TCP;
15             use NetPacket::UDP;
16             use NetPacket::IGMP;
17             use NetPacket::ICMP qw(:types);
18              
19             our $VERSION = "1.4209";
20             our $MIN_SNAPLEN = 256;
21             our $DEFAULT_PPL = 32;
22              
23             my %KNOWN_CALLBACKS = (map {($_=>1)} qw(
24             appletalk_callback arp_callback arpreply_callback arpreq_callback default_callback icmp_callback
25             icmpechoreply_callback icmpunreach_callback icmpsourcequench_callback icmpredirect_callback
26             icmpecho_callback icmprouteradvert_callback icmproutersolicit_callback icmptimxceed_callback
27             icmpparamprob_callback icmptstamp_callback icmptstampreply_callback icmpireq_callback
28             icmpireqreply_callback igmp_callback ipv4_callback ipv6_callback ppp_callback rarpreply_callback
29             rarpreq_callback snmp_callback tcp_callback udp_callback
30             ));
31              
32             sub DESTROY {
33             my $this = shift;
34              
35             my $p = delete $this->{pcap};
36             Net::Pcap::close($p) if $p;
37              
38             return;
39             }
40              
41             sub is_local {
42             my $this = shift;
43             my $nm = $this->cidr;
44              
45             my $r = eval { $nm->contains( @_ ) }; croak $@ if $@;
46             return $r;
47             }
48              
49             sub new {
50             my $class = shift;
51             my $this = bless { @_ }, $class;
52              
53             my $err;
54             my $pcap;
55             unless ($this->{pcap}) {
56             my $dev = $this->{dev};
57              
58             if( $dev =~ s/^file:// ) {
59             $pcap = $this->{pcap} =
60             Net::Pcap::open_offline($dev, \$err)
61             or die "error opening offline pcap file: $err";
62              
63             } else {
64             unless( $dev ) {
65             $dev = $this->{dev} = Net::Pcap::lookupdev(\$err);
66             croak "ERROR while trying to find a device: $err" unless $dev;
67             }
68              
69             my ($network, $netmask);
70             if (Net::Pcap::lookupnet($dev, \$network, \$netmask, \$err)) {
71             croak "ERROR finding net and netmask for $dev: $err";
72              
73             } else {
74             $this->{network} = $network;
75             $this->{netmask} = $netmask;
76             }
77              
78             my $ppl = $this->{packets_per_loop};
79             $ppl = $this->{packets_per_loop} = $DEFAULT_PPL unless defined $ppl and $ppl > 0;
80              
81             my $ttl = $this->{timeout_in_ms} || 250;
82             $ttl = 250 if $ttl < 0;
83              
84             my $snaplen = $this->{bytes_to_capture} || 1024;
85             $snaplen = $MIN_SNAPLEN unless $snaplen >= 256;
86              
87             $pcap = $this->{pcap} = Net::Pcap::open_live($dev, $snaplen, $this->{promiscuous}, $ttl, \$err);
88              
89             croak "ERROR opening pacp session: $err" if $err or not $pcap;
90             }
91              
92             for my $f (grep {m/_callback$/} keys %$this) {
93             croak "the $f option does not point to a CODE ref" unless ref($this->{$f}) eq "CODE";
94             warn "the $f option is not a known callback and will never get called" unless $KNOWN_CALLBACKS{$f};
95             }
96             }
97              
98             if( my $f = $this->{filter} ) {
99             my $filter;
100             Net::Pcap::compile( $pcap, \$filter, $f, 1, $this->{netmask} ) && croak 'ERROR compiling pcap filter';
101             Net::Pcap::setfilter( $pcap, $filter ) && die 'ERROR Applying pcap filter';
102             }
103              
104             $this->{_mcb} = sub {
105             my ($linktype, $header, $packet) = @_;
106              
107             # For non-ethernet data link types, construct a
108             # fake ethernet header from the data available.
109             my ($ether, $type);
110             if ($linktype == Net::Pcap::DLT_EN10MB) {
111             $ether = NetPacket::Ethernet->decode($packet);
112             $type = $ether->{type};
113              
114             } elsif ($linktype == Net::Pcap::DLT_LINUX_SLL) {
115             use bytes;
116             $type = unpack("n", substr($packet, 2+2+2+8, 2));
117             $ether = NetPacket::Ethernet->decode(
118             pack("h24 n", "0" x 24, $type) . substr($packet, 16));
119             no bytes;
120              
121             } else {
122             die "ERROR Unhandled data link type: " .
123             Net::Pcap::datalink_val_to_name($linktype);
124             }
125             $this->{_pp} ++;
126              
127             my $cb;
128              
129             return $this->_ipv4( $ether, NetPacket::IP -> decode($ether->{data}), $header) if $type == ETH_TYPE_IP;
130             return $this->_arp( $ether, NetPacket::ARP -> decode($ether->{data}), $header) if $type == ETH_TYPE_ARP;
131            
132             return $cb->($this, $ether, $header) if $type == ETH_TYPE_IPv6 and $cb = $this->{ipv6_callback};
133             return $cb->($this, $ether, $header) if $type == ETH_TYPE_SNMP and $cb = $this->{snmp_callback};
134             return $cb->($this, $ether, $header) if $type == ETH_TYPE_PPP and $cb = $this->{ppp_callback};
135             return $cb->($this, $ether, $header) if $type == ETH_TYPE_APPLETALK and $cb = $this->{appletalk_callback};
136              
137             return $cb->($this, $ether, $header) if $cb = $this->{default_callback};
138             };
139              
140             return $this;
141             }
142              
143             sub _icmp {
144             my ($this, $ether, $ip, $icmp, $header) = @_;
145              
146             my $cb;
147             my $type = $icmp->{type};
148              
149             return $cb->($this, $ether, $ip, $icmp, $header ) if $type == ICMP_ECHOREPLY and $cb = $this->{icmpechoreply_callback};
150             return $cb->($this, $ether, $ip, $icmp, $header ) if $type == ICMP_UNREACH and $cb = $this->{icmpunreach_callback};
151             return $cb->($this, $ether, $ip, $icmp, $header ) if $type == ICMP_SOURCEQUENCH and $cb = $this->{icmpsourcequench_callback};
152             return $cb->($this, $ether, $ip, $icmp, $header ) if $type == ICMP_REDIRECT and $cb = $this->{icmpredirect_callback};
153             return $cb->($this, $ether, $ip, $icmp, $header ) if $type == ICMP_ECHO and $cb = $this->{icmpecho_callback};
154             return $cb->($this, $ether, $ip, $icmp, $header ) if $type == ICMP_ROUTERADVERT and $cb = $this->{icmprouteradvert_callback};
155             return $cb->($this, $ether, $ip, $icmp, $header ) if $type == ICMP_ROUTERSOLICIT and $cb = $this->{icmproutersolicit_callback};
156             return $cb->($this, $ether, $ip, $icmp, $header ) if $type == ICMP_TIMXCEED and $cb = $this->{icmptimxceed_callback};
157             return $cb->($this, $ether, $ip, $icmp, $header ) if $type == ICMP_PARAMPROB and $cb = $this->{icmpparamprob_callback};
158             return $cb->($this, $ether, $ip, $icmp, $header ) if $type == ICMP_TSTAMP and $cb = $this->{icmptstamp_callback};
159             return $cb->($this, $ether, $ip, $icmp, $header ) if $type == ICMP_TSTAMPREPLY and $cb = $this->{icmptstampreply_callback};
160             return $cb->($this, $ether, $ip, $icmp, $header ) if $type == ICMP_IREQ and $cb = $this->{icmpireq_callback};
161             return $cb->($this, $ether, $ip, $icmp, $header ) if $type == ICMP_IREQREPLY and $cb = $this->{icmpireqreply_callback};
162              
163             # NOTE: MASKREQ is exported as MASREQ ... grrz: http://rt.cpan.org/Ticket/Display.html?id=37931
164             return $cb->($this, $ether, $ip, $icmp, $header ) if $type == NetPacket::ICMP::ICMP_MASKREQ() and $cb = $this->{icmpmaskreq_callback};
165             return $cb->($this, $ether, $ip, $icmp, $header ) if $type == ICMP_MASKREPLY and $cb = $this->{icmpmaskreply_callback};
166              
167             return $cb->($this, $ether, $ip, $icmp, $header ) if $cb = $this->{icmp_callback};
168             return $cb->($this, $ether, $ip, $icmp, $header ) if $cb = $this->{ipv4_callback};
169             return $cb->($this, $ether, $ip, $icmp, $header ) if $cb = $this->{default_callback};
170              
171             return;
172             }
173              
174             sub _ipv4 {
175             my ($this, $ether, $ip, $header) = @_;
176              
177             my $cb;
178             my $proto = $ip->{proto};
179              
180             # NOTE: this could probably be made slightly more efficient and less repeatative.
181              
182             return $cb->($this, $ether, $ip, NetPacket::TCP -> decode($ip->{data}), $header) if $proto == IP_PROTO_TCP and $cb = $this->{tcp_callback};
183             return $cb->($this, $ether, $ip, NetPacket::UDP -> decode($ip->{data}), $header) if $proto == IP_PROTO_UDP and $cb = $this->{udp_callback};
184             return $this->_icmp($ether,$ip, NetPacket::ICMP -> decode($ip->{data}), $header) if $proto == IP_PROTO_ICMP;
185             return $cb->($this, $ether, $ip, NetPacket::IGMP -> decode($ip->{data}), $header) if $proto == IP_PROTO_IGMP and $cb = $this->{igmp_callback};
186              
187             my $spo;
188             $spo = NetPacket::TCP -> decode($ip->{data}) if $proto == IP_PROTO_TCP;
189             $spo = NetPacket::UDP -> decode($ip->{data}) if $proto == IP_PROTO_UDP;
190             $spo = NetPacket::IGMP -> decode($ip->{data}) if $proto == IP_PROTO_IGMP;
191              
192             return $cb->($this, $ether, $ip, $spo, $header) if $cb = $this->{ipv4_callback};
193             return $cb->($this, $ether, $ip, $spo, $header) if $cb = $this->{default_callback};
194              
195             return;
196             }
197              
198             sub _arp {
199             my ($this, $ether, $arp, $header) = @_;
200              
201             my $cb;
202             my $op = $arp->{opcode};
203              
204             return $cb->($this, $ether, $arp, $header) if $op == ARP_OPCODE_REQUEST and $cb = $this->{arpreq_callback};
205             return $cb->($this, $ether, $arp, $header) if $op == ARP_OPCODE_REPLY and $cb = $this->{arpreply_callback};
206             return $cb->($this, $ether, $arp, $header) if $op == RARP_OPCODE_REQUEST and $cb = $this->{rarpreq_callback};
207             return $cb->($this, $ether, $arp, $header) if $op == RARP_OPCODE_REPLY and $cb = $this->{rarpreply_callback};
208              
209             return $cb->($this, $ether, $arp, $header) if $cb = $this->{arp_callback};
210             return $cb->($this, $ether, $arp, $header) if $cb = $this->{default_callback};
211              
212             return;
213             }
214              
215             sub loop {
216             my $this = shift;
217             my $cb = shift || $this->{_mcb};
218              
219             my $ret = Net::Pcap::loop($this->{pcap}, $this->{packets_per_loop}, $cb, Net::Pcap::datalink($this->{pcap}));
220              
221             return unless $ret == 0;
222             return (delete $this->{_pp}) || 0; # return the number of processed packets.
223             }
224              
225             sub pcap { return $_[0]->{pcap} }
226             sub raw_network { return $_[0]->{network} }
227             sub raw_netmask { return $_[0]->{netmask} }
228             sub dev { return $_[0]->{dev} }
229              
230             sub network {
231             my $this = shift;
232              
233             return Socket::inet_ntoa(scalar reverse pack("l", $this->{network}));
234             }
235              
236             sub netmask {
237             my $this = shift;
238              
239             return Socket::inet_ntoa(scalar reverse pack("l", $this->{netmask}));
240             }
241              
242             sub cidr {
243             my $this = shift;
244             my $nm = $this->{nm};
245             $nm = $this->{nm} = Net::Netmask->new($this->network . "/" . $this->netmask) unless $this->{nm};
246              
247             return $nm;
248             }
249              
250             sub stats {
251             my $this = shift;
252              
253             my %stats;
254             Net::Pcap::pcap_stats($this->{pcap}, \%stats);
255             $stats{ substr $_, 3 } = delete $stats{$_} for keys %stats;
256              
257             return wantarray ? %stats : \%stats;
258             }
259              
260             1;