File Coverage

blib/lib/Net/PcapWriter.pm
Criterion Covered Total %
statement 47 52 90.3
branch 5 10 50.0
condition 1 2 50.0
subroutine 14 14 100.0
pod 6 7 85.7
total 73 85 85.8


line stmt bran cond sub pod time code
1 7     7   3402 use strict;
  7         49  
  7         200  
2 7     7   37 use warnings;
  7         12  
  7         245  
3             package Net::PcapWriter;
4 7     7   3760 use Time::HiRes 'gettimeofday';
  7         9863  
  7         30  
5 7     7   4581 use Net::PcapWriter::TCP;
  7         17  
  7         232  
6 7     7   2862 use Net::PcapWriter::UDP;
  7         16  
  7         201  
7 7     7   2683 use Net::PcapWriter::ICMP_Echo;
  7         16  
  7         3962  
8              
9             our $VERSION = '0.725';
10              
11             sub new {
12 6     6 1 8553 my ($class,$file) = @_;
13 6         27 my $self = bless { fh => undef },$class;
14 6         25 $self->reopen($file);
15 6         18 return $self;
16             }
17              
18             sub reopen {
19 6     6 1 22 my ($self,$file) = @_;
20 6         13 my $fh;
21 6 50       23 if ( $file ) {
22 6 50       22 if ( ref($file)) {
23 6         15 $fh = $file
24             } else {
25 0 0       0 open($fh,'>',$file) or die "open $file: $!";
26 0         0 binmode($fh);
27             }
28             } else {
29 0         0 $fh = \*STDOUT;
30             }
31 6         38 $self->{fh} = $fh;
32 6         21 $self->_header;
33             }
34              
35             # write pcap header
36             sub _header {
37 6     6   15 my $self = shift;
38              
39             # struct pcap_file_header {
40             # bpf_u_int32 magic;
41             # u_short version_major;
42             # u_short version_minor;
43             # bpf_int32 thiszone; /* gmt to local correction */
44             # bpf_u_int32 sigfigs; /* accuracy of timestamps */
45             # bpf_u_int32 snaplen; /* max length saved portion of each pkt */
46             # bpf_u_int32 linktype; /* data link type (LINKTYPE_*) */
47             # };
48              
49 6         17 print {$self->{fh}} pack('LSSlLLL',
  6         38  
50             0xa1b2c3d4, # magic
51             2,4, # major, minor
52             0,0, # timestamps correction and accuracy
53             0xffff, # snaplen
54             1, # DLT_EN10MB
55             );
56             }
57              
58             sub layer2prefix {
59 6     6 0 23 my $ip = pop;
60 6 100       76 return pack("NnNnn",
61             0,1,0,1, # all macs 0:*
62             $ip =~m{:} ? 0x86dd: 0x0800, # ETH_TYPE_IP6 | ETH_TYPE_IP
63             );
64             }
65              
66             # write pcap packet
67             sub packet {
68 26     26 1 68 my ($self,$data,$timestamp) = @_;
69 26   50     165 $timestamp ||= [ gettimeofday() ];
70              
71             # struct pcap_pkthdr {
72             # struct timeval ts; /* time stamp */
73             # bpf_u_int32 caplen; /* length of portion present */
74             # bpf_u_int32 len; /* length this packet (off wire) */
75             # };
76              
77 26         41 my ($tsec,$tmsec);
78 26 50       66 if (ref($timestamp)) {
79             # array like in Time::HiRes
80 26         54 ($tsec,$tmsec) = @$timestamp;
81             } else {
82 0         0 $tsec = int($timestamp);
83 0         0 $tmsec = int(($timestamp - $tsec)*1_000_000);
84             }
85              
86 26         57 print {$self->{fh}} pack('LLLLa*',
  26         232  
87             $tsec,$tmsec, # struct timeval ts
88             length($data), # caplen
89             length($data), # len
90             $data, # data
91             );
92             }
93              
94              
95             # return new TCP connection object
96             sub tcp_conn {
97 2     2 1 13 my ($self,$src,$sport,$dst,$dport) = @_;
98 2         14 return Net::PcapWriter::TCP->new($self,$src,$sport,$dst,$dport);
99             }
100              
101             # return new UDP connection object
102             sub udp_conn {
103 2     2 1 13 my ($self,$src,$sport,$dst,$dport) = @_;
104 2         12 return Net::PcapWriter::UDP->new($self,$src,$sport,$dst,$dport);
105             }
106              
107             # return new ICMP_Echo "connection" object
108             sub icmp_echo_conn {
109 2     2 1 12 my ($self,$src,$dst,$id) = @_;
110 2         13 return Net::PcapWriter::ICMP_Echo->new($self,$src,$dst,$id);
111             }
112              
113             1;
114              
115             __END__