File Coverage

blib/lib/Net/Frame/Layer.pm
Criterion Covered Total %
statement 109 194 56.1
branch 20 56 35.7
condition n/a
subroutine 28 42 66.6
pod 23 23 100.0
total 180 315 57.1


line stmt bran cond sub pod time code
1             #
2             # $Id: Layer.pm,v 7609c9d085d3 2018/03/15 15:17:19 gomor $
3             #
4             package Net::Frame::Layer;
5 11     11   4791 use strict;
  11         25  
  11         301  
6 11     11   46 use warnings;
  11         17  
  11         1290  
7              
8             require Class::Gomor::Array;
9             require Exporter;
10             our @ISA = qw(Class::Gomor::Array Exporter);
11              
12             our %EXPORT_TAGS = (
13             consts => [qw(
14             NF_LAYER_NONE
15             NF_LAYER_UNKNOWN
16             NF_LAYER_NOT_AVAILABLE
17             )],
18             subs => [qw(
19             getHostIpv4Addr
20             getHostIpv4Addrs
21             getHostIpv6Addr
22             inetAton
23             inetNtoa
24             inet6Aton
25             inet6Ntoa
26             getRandomHighPort
27             getRandom32bitsInt
28             getRandom16bitsInt
29             convertMac
30             inetChecksum
31             )],
32             );
33             our @EXPORT_OK = (
34             @{$EXPORT_TAGS{consts}},
35             @{$EXPORT_TAGS{subs}},
36             );
37              
38 11     11   70 use constant NF_LAYER_NONE => 0;
  11         19  
  11         1153  
39 11     11   59 use constant NF_LAYER_UNKNOWN => 1;
  11         17  
  11         494  
40 11     11   55 use constant NF_LAYER_NOT_AVAILABLE => 2;
  11         15  
  11         774  
41              
42             our @AS = qw(
43             raw
44             payload
45             nextLayer
46             );
47             __PACKAGE__->cgBuildIndices;
48             __PACKAGE__->cgBuildAccessorsScalar(\@AS);
49              
50 11     11   62 no strict 'vars';
  11         14  
  11         330  
51              
52 11     11   48 use Carp;
  11         23  
  11         4721  
53              
54 9     9 1 119 sub new { shift->SUPER::new(nextLayer => NF_LAYER_NONE, @_) }
55              
56             sub layer {
57 9     9 1 20 my $layer = ref(shift);
58 9         46 $layer =~ s/^Net::Frame::Layer:://;
59 9         19 $layer;
60             }
61              
62             # XXX: may use some optimizations
63             sub pack {
64 8     8 1 18 my $self = shift;
65 8         26 my ($fmt, @args) = @_;
66 8         15 my $res;
67 8         15 eval { $res = CORE::pack($fmt, @args) };
  8         52  
68 8 50       52 $@ ? do { carp("@{[ref($self)]}: unable to pack structure\n"); undef }
  0         0  
  0         0  
  0         0  
69             : $res;
70             }
71              
72             sub unpack {
73 11     11 1 17 my $self = shift;
74 11         27 my ($fmt, $arg) = @_;
75 11         14 my @res;
76 11         17 eval { @res = CORE::unpack($fmt, $arg) };
  11         56  
77 11 50       75 $@ ? do { carp("@{[ref($self)]}: unable to unpack structure\n"); () }
  0         0  
  0         0  
  0         0  
78             : @res;
79             }
80              
81             sub getPayloadLength {
82 0     0 1 0 my $self = shift;
83 0 0       0 $self->payload ? length($self->payload) : 0;
84             }
85              
86 0     0 1 0 sub encapsulate { shift->nextLayer }
87 0     0 1 0 sub computeLengths { 1 }
88 0     0 1 0 sub computeChecksums { 1 }
89 0     0 1 0 sub print { $self->layer.': to implement' }
90 0     0 1 0 sub getLength { 0 }
91              
92 0     0 1 0 sub dump { CORE::unpack('H*', shift->raw) }
93              
94             #
95             # Useful subroutines
96             #
97              
98             # Load AF_INET and default imports from Socket. Safe back to at least 5.8.8.
99 11     11   5327 use Socket qw(:DEFAULT AF_INET);
  11         49775  
  11         6779  
100              
101             sub _setInet6Sub {
102 11     11   85 no strict 'refs';
  11         19  
  11         2607  
103              
104 11     11   18 my $inetp_found = 0;
105              
106             # Check Socket against some IPv6 functions and constants.
107 11         15 eval {
108 11         63 require Socket;
109 11         406 Socket->import(qw(AF_INET6 inet_pton inet_ntop));
110             };
111 11 50       42 if (! $@) { # Socket has support for required functions and constants.
112 11         27 *{__PACKAGE__.'::_inet_pton'} = \&Socket::inet_pton;
  11         34  
113 11         84 *{__PACKAGE__.'::_inet_ntop'} = \&Socket::inet_ntop;
  11         94  
114              
115 11         32 $inetp_found = 1;
116             }
117              
118             # Fallback to Socket6
119 11 50       51 if (! $inetp_found) {
120 0         0 eval {
121 0         0 require Socket6;
122 0         0 Socket6->import(qw(AF_INET6 inet_pton inet_ntop));
123             };
124 0 0       0 if (! $@) { # Socket6 has support for required functions and constants.
125 0         0 *{__PACKAGE__.'::_inet_pton'} = \&Socket6::inet_pton;
  0         0  
126 0         0 *{__PACKAGE__.'::_inet_ntop'} = \&Socket6::inet_ntop;
  0         0  
127             }
128             }
129              
130             # Unfortunately, we have to test if inet_ntop()/inet_pton() works (i.e., are implemented)
131             # If no support for inet_ntop/inet_pton, we branch to fake functions.
132 11 50       44 if ($inetp_found) {
133 11         29 eval {
134             # inet_pton() may exist, but die with:
135             # inet_pton not implemented on this architecture
136 11         182 _inet_pton(AF_INET6(), "::1");
137             };
138 11 50       44 if ($@) {
139 0         0 print "[!] inet_pton support: $@\n";
140 0     0   0 *{__PACKAGE__.'::_inet_pton'} = sub { return 0; };
  0         0  
  0         0  
141 0     0   0 *{__PACKAGE__.'::_inet_ntop'} = sub { return 0; };
  0         0  
  0         0  
142             }
143             else {
144 11         23 return 1; # OK
145             }
146             }
147              
148 0         0 die("[-] Net::Frame: inet_pton/inet_ntop: not supported by Socket nor Socket6: ".
149             "try upgrading your Perl version or Socket/Socket6 modules.\n");
150             }
151              
152             sub _setGetAddressSub {
153 11     11   72 no strict 'refs';
  11         19  
  11         4599  
154              
155 11     11   13 my $getaddr_found = 0;
156              
157             # Check Socket against some IPv6 functions and constants.
158 11         24 eval {
159 11         69 require Socket;
160 11         348 Socket->import(qw(getaddrinfo getnameinfo AF_INET6));
161             };
162 11 50       72 if (! $@) { # Socket has support for required functions and constants.
163 11         34 *{__PACKAGE__.'::_getAddress'} = sub {
164 12     12   27 my ($name) = @_;
165              
166             #print STDERR "*** Socket supports IPv6 OK\n";
167              
168 12         29 my %hints = (
169             family => Socket::AF_INET6(),
170             );
171 12         16451 my ($err, @res) = Socket::getaddrinfo($name, '', \%hints);
172 12 50       88 if ($err) {
173 0         0 carp("@{[(caller(0))[3]]}: unable to resolv `$name' hostname: getaddrinfo: $err\n");
  0         0  
174 0         0 return;
175             }
176 12 50       42 if (@res > 0) {
177 12         33 my $h = $res[0];
178             my ($err, $ipv6) = Socket::getnameinfo(
179 12         109 $h->{addr}, Socket::NI_NUMERICHOST() | Socket::NI_NUMERICSERV()
180             );
181 12 50       39 if ($err) {
182 0         0 carp("@{[(caller(0))[3]]}: unable to resolv `$name' hostname: getnameinfo: $err\n");
  0         0  
183 0         0 return;
184             }
185              
186 12         61 return $ipv6;
187             }
188             else {
189 0         0 carp("@{[(caller(0))[3]]}: unable to resolv `$name' hostname: getaddrinfo: $!\n");
  0         0  
190 0         0 return;
191             }
192 11         66 };
193              
194 11         22 $getaddr_found = 1;
195             }
196              
197             # Fallback to Socket6
198 11 50       35 if (! $getaddr_found) {
199 0         0 eval {
200 0         0 require Socket6;
201 0         0 Socket6->import(qw(getaddrinfo getnameinfo AF_INET6));
202             };
203 0 0       0 if (! $@) { # Socket6 has support for required functions and constants.
204 0         0 *{__PACKAGE__.'::_getAddress'} = sub {
205 0     0   0 my ($name) = @_;
206              
207             #print STDERR "*** Fallback to Socket6 support\n";
208              
209 0         0 my @res = Socket6::getaddrinfo($name, '', Socket6::AF_INET6(), SOCK_STREAM);
210 0 0       0 if (@res >= 5) {
211 0         0 my ($ipv6) = Socket6::getnameinfo(
212             $res[3], Socket6::NI_NUMERICHOST() | Socket6::NI_NUMERICSERV()
213             );
214              
215 0         0 return $ipv6;
216             }
217 0         0 };
218             }
219              
220 0         0 $getaddr_found = 1;
221             }
222              
223             # Unfortunately, we have to test if INET6 family is supported
224             # If no support, we branch to fake functions.
225 11 50       23 if ($getaddr_found) {
226 11         137 eval {
227             # getaddrinfo() may exist, but die with:
228             # getaddrinfo: ai_family not supported
229 11         32 _getAddress("::1");
230             };
231 11 50       31 if ($@) {
232 0         0 print "[!] getaddrinfo support: $@\n";
233 0     0   0 *{__PACKAGE__.'::_getAddress'} = sub { return 0; };
  0         0  
  0         0  
234 0     0   0 *{__PACKAGE__.'::_getAddress'} = sub { return 0; };
  0         0  
  0         0  
235             }
236             else {
237 11         7309 return 1; # OK
238             }
239             }
240              
241 0         0 die("[-] Net::Frame: getaddrinfo/getnameinfo: not supported by Socket nor Socket6: ".
242             "try upgrading your Perl version or Socket/Socket6 modules.\n");
243             }
244              
245             BEGIN {
246 11     11   45 _setInet6Sub();
247 11         24 _setGetAddressSub();
248             }
249              
250             require Net::IPv6Addr;
251              
252             sub getHostIpv4Addr {
253 1     1 1 49 my ($name) = @_;
254              
255             # No address given
256 1 50       3 if (! defined($name)) {
257 0         0 return;
258             }
259              
260             # Already an IPv4 address
261 1 50       4 if ($name =~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/) {
262 0         0 return $name;
263             }
264              
265 1         3081 my @addrs = (gethostbyname($name))[4];
266 1 50       18 @addrs ? return join('.', CORE::unpack('C4', $addrs[0]))
267 0         0 : carp("@{[(caller(0))[3]]}: unable to resolv `$name' hostname\n");
268              
269             # Error
270 0         0 return;
271             }
272              
273             sub getHostIpv4Addrs {
274 0     0 1 0 my ($name) = @_;
275              
276             # No address given
277 0 0       0 if (! defined($name)) {
278 0         0 return;
279             }
280              
281             # Already an IPv4 address
282 0 0       0 if ($name =~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/) {
283 0         0 return $name;
284             }
285              
286 0         0 my @addrs = (gethostbyname($name))[4];
287 0 0       0 @addrs ? return @addrs
288 0         0 : carp("@{[(caller(0))[3]]}: unable to resolv `$name' hostname\n");
289              
290             # Error
291 0         0 return ();
292             }
293              
294             sub getHostIpv6Addr {
295 1     1 1 64 my ($name) = @_;
296              
297             # No address given
298 1 50       3 if (! defined($name)) {
299 0         0 return;
300             }
301              
302             # Already an IPv6 address
303 1 50       5 if (Net::IPv6Addr::is_ipv6($name)) {
304 0         0 return $name;
305             }
306              
307 1         376 my $ipv6 = _getAddress($name);
308 1 50       5 if (! defined($ipv6)) {
309 0         0 carp("@{[(caller(0))[3]]}: unable to resolv `$name' hostname\n");
  0         0  
310 0         0 return;
311             }
312              
313 1         6 $ipv6 =~ s/%.*$//;
314              
315 1         4 return $ipv6;
316             }
317              
318 5     5 1 178 sub inetAton { Socket::inet_aton(shift()) }
319 5     5 1 97 sub inetNtoa { Socket::inet_ntoa(shift()) }
320 1     1 1 156 sub inet6Aton { _inet_pton(AF_INET6, shift()) }
321 1     1 1 74 sub inet6Ntoa { _inet_ntop(AF_INET6, shift()) }
322              
323             sub getRandomHighPort {
324 2     2 1 59 my $highPort = int rand 0xffff;
325 2 50       10 $highPort += 1024 if $highPort < 1025;
326 2         14 $highPort;
327             }
328              
329 1     1 1 8 sub getRandom32bitsInt { int rand 0xffffffff }
330 1     1 1 37 sub getRandom16bitsInt { int rand 0xffff }
331              
332             sub convertMac {
333 4     4 1 30 return lc(join(':', $_[0] =~ /../g));
334             }
335              
336             sub inetChecksum {
337 0     0 1   my ($phpkt) = @_;
338              
339 0 0         $phpkt .= "\x00" if length($phpkt) % 2;
340 0           my $len = length $phpkt;
341 0           my $nshort = $len / 2;
342 0           my $checksum = 0;
343 0           $checksum += $_ for CORE::unpack("S$nshort", $phpkt);
344             # XXX: This line never does anything as the lenth was made even above. Currently testing it breaks nothing.
345             #$checksum += CORE::unpack('C', substr($phpkt, $len - 1, 1)) if $len % 2;
346 0           $checksum = ($checksum >> 16) + ($checksum & 0xffff);
347              
348 0           CORE::unpack('n',
349             CORE::pack('S', ~(($checksum >> 16) + $checksum) & 0xffff),
350             );
351             }
352              
353             1;
354              
355             __END__