File Coverage

blib/lib/Net/PcapWriter/IP.pm
Criterion Covered Total %
statement 60 83 72.2
branch 20 32 62.5
condition 6 14 42.8
subroutine 11 16 68.7
pod 0 6 0.0
total 97 151 64.2


line stmt bran cond sub pod time code
1 7     7   35 use strict;
  7         14  
  7         193  
2 7     7   39 use warnings;
  7         11  
  7         281  
3             package Net::PcapWriter::IP;
4 7     7   6515 use Socket qw(AF_INET AF_INET6);
  7         28457  
  7         1502  
5              
6 7     7   48 use base 'Exporter';
  7         13  
  7         1652  
7             # re-export the usable inet_pton
8             our @EXPORT = qw(ip_chksum ip4_packet ip6_packet ip_packet inet_pton);
9              
10              
11             my $do_chksum = 1;
12 0     0 0 0 sub calculate_checksums { $do_chksum = $_[1] }
13              
14             BEGIN {
15             # inet_pton is in Socket since 5.12
16             # but even if it is in Socket it can throw a non-implemented error
17             eval {
18 7         171 Socket->import('inet_pton');
19 7         61 inet_pton(AF_INET,'127.0.0.1');
20 7         42 inet_pton(AF_INET6,'::1');
21 7         7239 1
22 7 50 33 7   17 } or eval {
23 0         0 require Socket6;
24 0         0 Socket6->import('inet_pton');
25 0         0 inet_pton(AF_INET,'127.0.0.1');
26 0         0 inet_pton(AF_INET6,'::1');
27 0         0 1
28             } or die "you need either a modern perl or Socket6"
29             }
30              
31              
32             # construct IPv4 packet or packet generating sub
33             sub ip4_packet {
34 7     7 0 23 my ($data,$src,$dst,$protocol,$chksum_offset,$no_pseudo_header) = @_;
35 7 100 50     118 my $hdr = pack('CCnnnCCna4a4',
      50        
36             0x45, # version 4, len=5 (no options)
37             0, # type of service
38             defined($data) ? length($data)+20 : 20, # total length
39             0,0, # id=0, not fragmented
40             128, # TTL
41             $protocol,
42             0, # checksum - computed later
43             scalar(inet_pton(AF_INET,$src) || die "no IPv4 $src"),
44             scalar(inet_pton(AF_INET,$dst) || die "no IPv4 $dst"),
45             );
46              
47 7 100       34 if (defined $data) {
48 3 50       9 return $hdr.$data if ! $do_chksum;
49 3 50       9 if (defined $chksum_offset) {
50 3 50       8 my $ckdata = $no_pseudo_header ? $data :
51             substr($hdr,-8).pack('xCna*',
52             $protocol,length($data), # proto + len
53             $data
54             );
55 3         9 substr($data,$chksum_offset, 2) = pack('n',ip_chksum($ckdata));
56             }
57 3         7 substr($hdr,10,2) = pack('n',ip_chksum($hdr));
58 3         23 return $hdr.$data;
59             }
60              
61             # data not defined, return sub which creates packet once data are known
62 4 50       15 if (!$do_chksum) {
63             return sub {
64 0     0   0 substr(my $lhdr = $hdr,2,2) = pack('n',length($_[0])+20);
65 0         0 return $lhdr.$_[0];
66 0         0 };
67             }
68              
69 4 50       16 if (! defined $chksum_offset) {
70             return sub {
71 0     0   0 substr(my $lhdr = $hdr,2,2) = pack('n',length($_[0])+20);
72 0         0 substr($lhdr,10,2) = pack('n',ip_chksum($lhdr));
73 0         0 return $lhdr.$_[0];
74 0         0 };
75             }
76             return sub {
77 10     10   22 my $data = shift;
78 10 50       67 my $ckdata = $no_pseudo_header ? $data :
79             substr($hdr,-8).pack('xCna*',
80             $protocol,length($data), # proto + len
81             $data
82             );
83 10         32 substr($data,$chksum_offset, 2) = pack('n',ip_chksum($ckdata));
84 10         39 substr(my $lhdr = $hdr,2,2) = pack('n',length($data)+20);
85 10         33 substr($lhdr,10,2) = pack('n',ip_chksum($lhdr));
86 10         83 return $lhdr.$data;
87 4         45 };
88             }
89              
90             # construct IPv6 packet
91             sub ip6_packet {
92 7     7 0 18 my ($data,$src,$dst,$protocol,$chksum_offset) = @_;
93 7 100 50     101 my $hdr = pack('NnCCA16A16',
      50        
94             6 << 28 | 0 << 20 | 0, # version, traffic class, flow label
95             defined($data) ? length($data) : 0, # length of payload
96             $protocol, # next header = protocol
97             128, # hop limit
98             scalar(inet_pton(AF_INET6,$src) || die "no IPv6 $src"),
99             scalar(inet_pton(AF_INET6,$dst) || die "no IPv6 $dst"),
100             );
101              
102 7 100       22 if (defined $data) {
103             # return packet
104 3 50 33     17 if ($do_chksum && defined $chksum_offset) {
105 3         11 my $ckdata = substr($hdr,-32).pack('NxxxCa*',
106             length($data), $protocol, # len + proto
107             $data
108             );
109 3         8 substr($data,$chksum_offset, 2) = pack('n',ip_chksum($ckdata));
110             }
111 3         17 return $hdr.$data;
112             }
113              
114             # data not defined, return sub which creates packet once data are known
115 4 50       11 if (! defined $chksum_offset) {
116             return sub {
117 0     0   0 substr($hdr,4,2) = pack('n',length($_[0]));
118 0         0 return $hdr.$_[0]
119             }
120 0         0 }
121             return sub {
122 10     10   18 my $data = shift;
123 10         22 substr($hdr,4,2) = pack('n',length($data));
124 10 50       23 if ($do_chksum) {
125 10         35 my $ckdata = substr($hdr,-32).pack('NxxxCa*',
126             length($data), $protocol, # len + proto
127             $data
128             );
129 10         22 substr($data,$chksum_offset, 2) = pack('n',ip_chksum($ckdata));
130             }
131 10         47 return $hdr.$data;
132 4         30 };
133             }
134              
135             sub ip_packet {
136 8 100   8 0 67 goto &ip6_packet if $_[1] =~m{:};
137 4         21 goto &ip4_packet;
138             }
139              
140             sub ip_chksum16 {
141 0     0 0 0 my $data = pop;
142 0 0       0 $data .= "\x00" if length($data) % 2; # padding
143 0         0 my $sum = 0;
144 0         0 $sum += $_ for (unpack('n*', $data));
145 0         0 $sum = ($sum >> 16) + ($sum & 0xffff);
146 0         0 $sum = ~(($sum >> 16) + $sum) & 0xffff;
147 0         0 return $sum;
148             }
149              
150             sub ip_chksum32 {
151 39     39 0 80 my $data = pop;
152 39         201 $data .= "\x00" x (4 - length($data) % 4); # padding
153 39         72 my $sum = 0;
154 39         280 $sum += $_ for unpack('N*', $data);
155 39         88 $sum = ($sum >> 16) + ($sum & 0xffff);
156 39         66 $sum = ($sum >> 16) + ($sum & 0xffff);
157 39         67 $sum = ($sum >> 16) + ($sum & 0xffff);
158 39         151 return ~$sum;
159             }
160              
161             require Config;
162             *ip_chksum = $Config::Config{ivsize} == 8 ? \&ip_chksum32 : \&ip_chksum16;
163              
164             1;