File Coverage

blib/lib/IPv6/Address.pm
Criterion Covered Total %
statement 218 235 92.7
branch 71 102 69.6
condition 4 6 66.6
subroutine 62 65 95.3
pod 29 31 93.5
total 384 439 87.4


line stmt bran cond sub pod time code
1 1     1   21804 use strict;
  1         3  
  1         34  
2 1     1   4 use warnings;
  1         2  
  1         72  
3              
4             package IPv6::Address;
5             $IPv6::Address::VERSION = '0.207';
6              
7             =head1 NAME
8              
9             IPv6::Address - IPv6 Address Manipulation Library
10              
11             =head1 VERSION
12              
13             version 0.207
14              
15             =for html
16            
17             Coverage Status
18              
19              
20             =head1 SYNOPSIS
21              
22             use IPv6::Address;
23              
24             my $ipv6 = IPv6::Address->new('2001:648:2000::/48');
25              
26             $ipv6->contains('2001:648:2000::/64'); #true
27              
28             say $ipv6->to_string;
29             say $ipv6->string; # Same as previous
30             say $ipv6; # Same as previous
31              
32             say $ipv6->string(nocompress=>1); # do not compress using the :: notation
33             say $ipv6->string(ipv4=>1); #print the last 32 bits as an IPv4 address
34            
35             $ipv6->addr_string; # Returns '2001:648:2000::'
36            
37             $ipv6->split(4); # Split the prefix into 2^4 smaller prefixes. Returns a list.
38              
39             $ipv6->apply_mask; # Apply the mask to the address. All bits beyond the mask length become 0.
40              
41             $ipv6->first_address;
42              
43             $ipv6->last_address;
44              
45             $a->enumerate_with_offset( 5 , 64 ); #returns 2001:648:2000:4::/64
46              
47             =head1 DESCRIPTION
48              
49             A pure Perl IPv6 address manipulation library. Emphasis on manipulation of
50             prefixes and addresses. Very easy to understand and modify. The internal
51             representation of an IPv6::Address is a blessed hash with two keys, a prefix
52             length (0-128 obviously) and a 128-bit string. A multitude of methods to do
53             various tasks is provided.
54              
55              
56             =head2 Methods
57              
58             =over 12
59              
60             =cut
61              
62 1     1   3 use strict;
  1         1  
  1         14  
63 1     1   2 use warnings;
  1         1  
  1         22  
64 1     1   3 use Carp;
  1         1  
  1         53  
65 1     1   510 use Data::Dumper;
  1         6294  
  1         44  
66 1     1   376 use Sub::Install;
  1         1110  
  1         3  
67              
68             use overload
69 1         6 '""' => \&to_string,
70             '<=>' => \&n_cmp,
71 1     1   39 fallback => 1;
  1         1  
72            
73             my $DEBUG = 0;
74              
75             sub debug {
76 107 50   107 0 165 $DEBUG&&print STDERR $_[0];
77 107 50       137 $DEBUG&&print STDERR "\n";
78            
79             }
80              
81             =item C
82              
83             Takes a string representation of an IPv6 address and creates a corresponding
84             IPv6::Address object.
85              
86             =cut
87              
88             #takes a normal address as argument. Example 2001:648:2000::/48
89             sub new {
90 41 50   41 1 1756 my $class = shift(@_) or croak "incorrect call to new";
91 41 50       58 my $ipv6_string = shift(@_) or croak "Cannot use an empty string as argument";
92 41         151 my ($ipv6,$prefixlen) = ( $ipv6_string =~ /([0-9A-Fa-f:]+)\/(\d+)/ );
93 41 50       57 croak "IPv6 address part not parsable" if (!defined($ipv6));
94 41 50       63 croak "IPv6 prefix length part not parsable" if (!defined($prefixlen));
95 41         72 debug("ipv6 is $ipv6, length is $prefixlen");
96 41         49 my @arr;
97 41         128 my @_parts = ( $ipv6 =~ /([0-9A-Fa-f]+)/g );
98 41         36 my $nparts = scalar @_parts;
99 41 100       60 if ($nparts != 8) {
100 33         57 for(my $i=1;$i<=(8-$nparts);$i++) { push @arr,hex "0000" };
  194         252  
101             }
102              
103 41 100       136 my @parts = map { ($_ eq '::')? @arr : hex $_ } ( $ipv6 =~ /((?:[0-9A-Fa-f]+)|(?:::))/g );
  167         245  
104            
105 41         54 debug(join(":",map { sprintf "%04x",$_ } @parts));
  328         370  
106              
107 41         93 my $bitstr = pack 'n8',@parts;
108            
109 41         149 return bless {
110             bitstr => $bitstr,
111             prefixlen => $prefixlen,
112             },$class;
113             }
114              
115             =item C
116              
117             Creates a new IPv6::Address out of a bitstring and a prefix length. The
118             bitstring must be binary, please do not use a '0' or '1' character string.
119              
120             =cut
121              
122             #takes a bitstr (0101010101111010010....) and a prefix length as arguments
123             sub raw_new {
124 34     34 1 29 my $class = $_[0];
125 34         142 return bless {
126             bitstr => $_[1],
127             prefixlen => $_[2],
128             },$class;
129             }
130              
131             =item C
132              
133             Returns the bitstr of the object.
134              
135             =cut
136              
137             #returns the bitstr (11010111011001....)
138             sub get_bitstr {
139 215     215 1 446 return $_[0]->{bitstr};
140             }
141              
142              
143             =item C
144              
145             Returns the prefix length of the address.
146              
147             =cut
148              
149             #returns the length of the IPv6 address prefix
150             sub get_prefixlen {
151 215     215 1 712 return $_[0]->{prefixlen};
152             }
153              
154             =item C
155              
156             Returns a 128-bit string with the first prefix-length bits equal
157             to 1, rest equal to 0. Essentially takes the prefix length of the object and
158             returns a corresponding bit mask.
159              
160             =cut
161              
162             #returns a 1111100000 corresponding to the prefix length
163             sub get_mask_bitstr {
164 3     3 1 6 generate_bitstr( $_[0]->get_prefixlen )
165             }
166              
167             =item C
168              
169             Returns the bitstring, after zeroing out all the bits after the prefix length.
170             Essentially applies the prefix mask to the address.
171              
172             =cut
173             sub get_masked_address_bitstr {
174 8     8 1 10 generate_bitstr( $_[0]->get_prefixlen ) & $_[0]->get_bitstr;
175             }
176              
177             =item C
178              
179             Not a method, returns 128-bit string, first n-items are 1, rest is 0.
180              
181             =cut
182              
183             sub generate_bitstr {
184             #TODO trick bellow is stupid ... fix
185 19     19 1 53 pack 'B128',join('',( ( map { '1' } ( 1 .. $_[0] ) ) , ( map { '0' } ( 1 .. 128-$_[0] ) ) ));
  768         506  
  1664         1119  
186             }
187              
188             =item C
189              
190             Not a method, AND's two bitstrings, returns result.
191              
192             =cut
193             #takes two bitstrs as arguments and returns their logical or as bitstr
194             sub bitstr_and {
195 1     1 1 3 return $_[0] & $_[1]
196             }
197              
198             =item C
199              
200             Not a method, OR's two bitstrings, returns result.
201              
202             =cut
203             #takes two bitstrs as arguments and returns their logical or as bitstr
204             sub bitstr_or {
205 1     1 1 2 return $_[0] | $_[1]
206             }
207              
208             =item C
209              
210             Not a method, inverts a bitstring.
211              
212             =cut
213             #takes a bitstr and inverts it
214             sub bitstr_not {
215 1     1 1 3 return ~ $_[0]
216             }
217              
218             =item C
219              
220             Not a method, takes a string of characters 0 or 1, returns corresponding binary
221             bitstring. Please do not use more than 128 characters, rest will be ignored.
222              
223             =cut
224              
225             #converts a bitstr (111010010010....) to a binary string
226             sub from_str {
227 32     32 1 33 my $str = shift(@_);
228 32         87 return pack("B128",$str);
229             }
230              
231             =item C
232              
233             Not a method, takes a binary bitstring, returns a string composed of 0's and
234             1's. Please supply bitstrings of max. 128 bits, rest of the bits will be
235             ignored.
236              
237             =cut
238              
239             #converts from binary to literal bitstr
240             sub to_str {
241 41     41 1 39 my $bitstr = shift(@_);
242 41         131 return join('',unpack("B128",$bitstr));
243             }
244              
245             =item C
246              
247             This method takes an argument which is either an IPv6::Address or a plain string
248             that can be promoted to a valid IPv6::Address, and tests whether the object
249             contains it. Obviously returns true or false.
250              
251             =cut
252              
253             sub contains {
254 9 50   9 1 19 defined( my $self = shift(@_) ) or die 'incorrect call';
255 9 50       11 defined( my $other = shift(@_) ) or die 'incorrect call';
256 9 50       16 if (ref($other) eq '') {
257 9         12 $other = __PACKAGE__->new($other);
258             }
259 9 100       12 return if ($self->get_prefixlen > $other->get_prefixlen);
260 8 100       12 return 1 if $self->get_masked_address_bitstr eq ( generate_bitstr( $self->get_prefixlen ) & $other->get_bitstr );
261             #return 1 if (substr($self->get_bitstr,0,$self->get_prefixlen) eq substr($other->get_bitstr,0,$self->get_prefixlen));
262 1         12 return;
263             }
264              
265             =item C
266              
267             Returns the address part of the IPv6::Address. Using the option ipv4=>1 like
268              
269             $a->addr_string(ipv4=>1)
270              
271             will make the last 32-bits appear as an IPv4 address. Also, using nocompress=>1
272             like
273              
274             $a->addr_string( nocompress => 1 )
275              
276             will prevent the string from containing a '::' part. So it will be 8 parts
277             separated by ':' colons.
278              
279             =cut
280              
281             #returns the address part (2001:648:2000:0000:0000....)
282             sub addr_string {
283 54     54 1 42 my $self = shift(@_);
284 54         75 my $str = join(':',map { sprintf("%x",$_) } (unpack("nnnnnnnn",$self->get_bitstr)) );
  432         531  
285 54         99 my $str2 = join(':',map { sprintf("%04x",$_) } (unpack("nnnnnnnn",$self->get_bitstr)) );
  432         437  
286             #print Dumper(@_);
287 54         97 my %option = (@_) ;
288             #print Dumper(\%option);
289 54 50 66     108 if (defined($option{ipv4}) && $option{ipv4}) {
290             ###print "string:",$str,"\n";
291 3         5 $str = join(':',map { sprintf("%x",$_) } (unpack("nnnnnn",$self->get_bitstr)) ).':'.join('.', map {sprintf("%d",hex $_)} ($str2 =~ /([0-9A-Fa-f]{2})([0-9A-Fa-f]{2}):([0-9A-Fa-f]{2})([0-9A-Fa-f]{2})$/));
  18         37  
  12         21  
292             #print STDERR $ipv4,"\n";
293            
294             }
295             #print 'DEBUG:' . $str,"\n";
296 54 100       71 return $str2 if $option{full};
297 53 100       67 return $str if $option{nocompress};
298 51 100       93 return '::' if($str eq '0:0:0:0:0:0:0:0');
299 48         75 for(my $i=7;$i>1;$i--) {
300 181         372 my $zerostr = join(':',split('','0'x$i));
301             ###print "DEBUG: $str $zerostr \n";
302 181 100       2354 if($str =~ /:$zerostr$/) {
    100          
    100          
303 34         126 $str =~ s/:$zerostr$/::/;
304 34         103 return $str;
305             }
306             elsif ($str =~ /:$zerostr:/) {
307 9         33 $str =~ s/:$zerostr:/::/;
308 9         39 return $str;
309             }
310             elsif ($str =~ /^$zerostr:/) {
311 4         24 $str =~ s/^$zerostr:/::/;
312 4         23 return $str;
313             }
314             }
315 1         2 return $str;
316             }
317              
318             =item C
319              
320             Returns the full IPv6 address, with the prefix in its end.
321              
322             =cut
323              
324             #returns the full IPv6 address
325             sub string {
326 48     48 1 54 my $self = shift(@_);
327 48         71 return $self->addr_string(@_).'/'.$self->get_prefixlen;
328             }
329              
330             =item C
331              
332             Used internally by the overload module.
333              
334             =cut
335             #to be used by the overload module
336             sub to_string {
337 41     41 1 3708 return $_[0]->string();
338             }
339              
340             =item C
341              
342             Splits the address to the order of two of the number given as first argument.
343             Example: if argument is 3, 2^3=8, address is split into 8 parts. The final parts
344             have prefix length equal to the target_length specified in the second argument.
345              
346             =cut
347             sub split {
348 0     0 1 0 my $self = shift(@_);
349 0         0 my $split_length = shift(@_);#example: 3
350 0         0 my $networks = 2**$split_length;#2**3 equals 8 prefixes
351 0         0 my @bag = ();
352 0         0 for(my $i=0;$i<$networks;$i++) { #from 0 to 7
353 0         0 my $b_str = sprintf("%0${split_length}b",$i); # 001,010,011 and so on util 111 (7)
354 0         0 my $addr_str = $self->get_bitstr; #get the original bitstring of the address
355 0         0 substr($addr_str,$self->get_prefixlen,$split_length) = $b_str; #replace the correct 3 bits with $b_str
356 0         0 debug $addr_str,"\n";
357 0         0 push @bag,(__PACKAGE__->raw_new($addr_str,$self->get_prefixlen + $split_length)); #create and store the new addr
358             }
359 0         0 return @bag;
360             }
361              
362            
363             =item C
364              
365             Applies the prefix length mask to the address. Does not return anything. Works on $self.
366             BThis will alter the object.
367              
368             =cut
369             sub apply_mask {
370 0     0 1 0 my $self = shift(@_);
371 0         0 $self->{bitstr} = bitstr_and($self->get_bitstr,$self->get_mask_bitstr);
372             }
373              
374             =item C
375              
376             Returns the first address of the prefix that is represented by the object. E.g.
377             consider 2001:648:2000::1234/64. First address will be 2001:648:2000::/64.
378              
379             =cut
380              
381             sub first_address {
382 1     1 1 3 my $bitstr = bitstr_and( $_[0]->get_bitstr , $_[0]->get_mask_bitstr );
383 1         6 IPv6::Address->raw_new( $bitstr, $_[0]->get_prefixlen);
384             }
385              
386             =item C
387              
388             Returns the last address of the prefix that is represented by the object. E.g.
389             consider 2001:648:2000::1234/64. Last address will be
390             2001:648:2000::ffff:ffff:ffff:ffff/64.
391              
392             =cut
393             sub last_address {
394 1     1 1 2 my $bitstr = bitstr_or( $_[0]->get_bitstr , bitstr_not( $_[0]->get_mask_bitstr ) );
395 1         7 IPv6::Address->raw_new( $bitstr, $_[0]->get_prefixlen);
396             }
397            
398              
399             =item C , C , C
400              
401             Returns true or false depending on whether the address falls into the
402             corresponding category stated by the method name. E.g.
403              
404             IPv6::Address->new('::1')->is_loopback # returns true
405              
406             =cut
407              
408             my %patterns = (
409             unspecified => "^::\$",
410             loopback => "^::1\$",
411             multicast => "^ff",
412             );
413             #@TODO: implement this
414             my %binary_patterns = (
415             "link-local unicast" => "^",
416             );
417              
418              
419             for my $item (keys %patterns) {
420             Sub::Install::install_sub({
421             code => sub {
422 6 100   6   187 return ( shift(@_)->addr_string =~ /$patterns{$item}/i )? 1 : 0;
423             },
424             into => __PACKAGE__,
425             as => 'is_'.$item,
426             });
427             }
428              
429 1     1   1158 use strict;
  1         1  
  1         787  
430              
431             =item C
432              
433             Not a method, takes an IPv4 address, returns a character string consisting of 32
434             characters that are 0 or 1. Used internally, not too useful for the end user.
435              
436             =cut
437             sub ipv4_to_binarray {
438 1 50   1 1 2 defined( my $ipv4 = shift ) or die 'Missing IPv4 address argument';
439 1         3 my @parts = ( split('\.',$ipv4) );
440 1         2 my @binarray = split('',join('',map { sprintf "%08b",$_ } @parts));
  4         12  
441             #debug(Dumper(\@binarray));
442 1         12 return @binarray;
443             }
444              
445              
446              
447             =item C
448              
449             Takes an IPv4 address and uses a part of it to enumerate inside the Ipv6 prefix
450             of the object. E.g.
451              
452             IPv6::Address->new('2001:648:2001::/48')->enumerate_with_IPv4('0.0.0.1',0x0000ffff) #will yield 2001:648::2001:0001::/64
453              
454             The return value will be a new IPv6::Address object, so the original object
455             remains intact. The part that will be used as an offset is extracted from the
456             ipv4 by using the mask.
457              
458             =cut
459              
460             sub enumerate_with_IPv4 {
461 1 50   1 1 178 my ($self,$IPv4,$mask) = (@_) or die 'Incorrect call';
462 1         3 my $binmask = sprintf "%032b",$mask;
463            
464 1         3 my @IPv4 = ipv4_to_binarray($IPv4);
465 1         1 my $binary = '';
466 1         4 for(my $i=0;$i<32;$i++) {
467             #debug("$i ".substr($binmask,$i,1));
468 32 100       59 $binary = $binary.$IPv4[$i] if substr($binmask,$i,1) == 1;
469             }
470 1         3 debug($binary);
471 1         2 my $new_prefixlen = $self->get_prefixlen + length($binary);
472 1         2 my $new_bitstr = to_str( $self->get_bitstr );
473 1         2 debug($new_bitstr);
474 1         3 substr($new_bitstr, ($self->get_prefixlen), length($binary)) = $binary;
475 1         2 debug("old bitstring is ".$self->get_bitstr);
476 1         2 debug("new bitstring is $new_bitstr");
477 1         2 debug($new_prefixlen);
478            
479 1         2 return __PACKAGE__->raw_new(from_str($new_bitstr),$new_prefixlen);
480             }
481              
482             =item C
483              
484             Takes a non-negative integer offset and returns a prefix whose relative position
485             inside the object is defined by the offset. The prefix length of the result is
486             defined by the second argument. E.g.
487              
488             IPv6::Address->new('2001:648:2000::/48')->enumerate_with_offset( 5 , 64 ) #2001:648:2000:4::/64
489              
490             =cut
491              
492             sub enumerate_with_offset {
493 20 50   20 1 230 my ($self,$offset,$desired_length) = (@_) or die 'Incorrect call';
494 20         25 my $to_replace_len = $desired_length - $self->get_prefixlen;
495 20         23 my $new_bitstr = to_str( $self->get_bitstr );
496 20         55 my $offset_bitstr = sprintf("%0*b",$to_replace_len,$offset);
497 20         38 debug("offset number is $offset (or: $offset_bitstr)");
498             #consistency check
499 20 100       73 die "Tried to replace $to_replace_len bits, but for $offset, ".length($offset_bitstr)." bits are required"
500             if(length($offset_bitstr) > $to_replace_len);
501 18         20 substr($new_bitstr, ($self->get_prefixlen), length($offset_bitstr) ) = $offset_bitstr;
502 18         22 return __PACKAGE__->raw_new(from_str($new_bitstr),$desired_length);
503             }
504              
505             =item C
506              
507             Increments the IPv6::Address object by offset. Offsets larger than 2^32-1 are
508             not acceptable. This method is probably not too useful, but is provided for
509             completeness.
510              
511             =cut
512              
513             sub increment {
514 15 50   15 1 396 my ( $self , $offset ) = (@_) or die 'Incorrect call';
515              
516 15         16 my $max_int = 2**32-1;
517 15 50       22 die 'Sorry, offsets beyond 2^32-1 are not acceptable' if( $offset > $max_int );
518 15 100       20 die 'Sorry, cannot offset a /0 prefix. ' if ( $self->get_prefixlen == 0 );
519              
520 14         20 my $new_bitstr = to_str( $self->get_bitstr ); #will use it to store the new bitstr
521              
522 14 50       26 $DEBUG && print STDERR "Original bitstring is $new_bitstr\n";
523              
524             # 0..127
525 14 50       15 my $start = ($self->get_prefixlen>=32)? $self->get_prefixlen - 32 : 0 ;
526 14         14 my $len = $self->get_prefixlen - $start;
527              
528 14 50       18 $DEBUG && print STDERR "will replace from pos $start (from 0) and for $len len\n";
529              
530             # extract start..start+len part, 0-pad to 32 bits, pack into a network byte order $n
531 14         70 my $n = unpack('N',pack('B32',sprintf("%0*s",32,substr($new_bitstr, $start , $len ))));
532              
533 14 50       24 $DEBUG && print STDERR "Original n=".$n."\n";
534 14         8 $n += $offset;
535 14 50       20 $DEBUG && print STDERR "Result n=".$n."\n";
536              
537 14 100       24 die "Sorry, address part exceeded $max_int" if( $n > $max_int ); #just a precaution
538              
539             # repack the $n into a 32bit network ordered integer, convert into "1000101010101..." string
540 13         19 my $bstr = unpack( "B32", pack( 'N' , $n ) );
541              
542 13 50       15 $DEBUG && print STDERR "Replacement bitstr is $bstr\n";
543 13 50       23 die 'internal error. Address should be 32-bits long' unless (length($bstr) == 32); #another precaution
544            
545             #replace into new_bitstr from start and for len with bstr up for len bytes counting from the *end*
546 13         19 substr( $new_bitstr , $start , $len ) = substr( $bstr, - $len);
547              
548             # result is ready, return it
549 13         19 return __PACKAGE__->raw_new(from_str($new_bitstr),$self->get_prefixlen);
550             }
551              
552             =item C
553              
554             Takes the bitstring of the address and unpacks it using the first argument.
555             Internal use mostly.
556              
557             =cut
558              
559             sub nxx_parts {
560 44     44 1 43 unpack($_[1],$_[0]->get_bitstr)
561             }
562              
563             =item C
564              
565             Splits the address into an 8-item array of unsigned short integers. Network byte
566             order is implied, a short integer is 16-bits long.
567              
568             =cut
569              
570             #@TODO add tests for this method
571             sub n16_parts {
572 0     0 1 0 ( $_[0]->nxx_parts('nnnnnnnn') )
573             }
574              
575             =item C
576              
577             Splits the address into an 4-item array of unsigned long integers. Network byte
578             order is implied, a long integer is 32-bits long.
579              
580             =cut
581             #@TODO add tests for this method
582             sub n32_parts {
583 44     44 0 43 ( $_[0]->nxx_parts('NNNN') )
584             }
585              
586             =item C
587              
588             Takes two 128-bit bitstr arguments, compares them and returns the result as -1,
589             0 or 1. The semantics are the same as that of the spaceship operator <=>.
590              
591             This method will overload the <=> operator for IPv6::Address objects, so
592             comparing IPv6::Address objects like they were integers produces the correct
593             results.
594              
595             =cut
596              
597             #@TODO add tests for this method
598             sub n_cmp {
599 22     22 1 38 my @a = $_[0]->n32_parts;
600 22         26 my @b = $_[1]->n32_parts;
601 22         34 for ( 0 .. 3 ) {
602 64         42 my $cmp = ( $a[$_] <=> $b[$_] );
603 64 100       106 return $cmp if ( $cmp != 0 );
604             }
605 10         20 return 0;
606             }
607              
608             =item C
609              
610             Sorts an array of bitstrs using the n_cmp function.
611              
612             =cut
613              
614             sub n_sort {
615 1     1 1 5 sort { $a <=> $b } @_;
  8         8  
616             }
617              
618             =item C
619              
620             Returns a string suitable to be returned as an IPv6 Radius AV-pair. See RFC 3162
621             for an explanation of the format.
622              
623             =back
624             =cut
625              
626             sub radius_string {
627 6 50   6 1 429 defined(my $self = shift) or die 'Missing argument';
628             #Framed-IPv6-Prefix := 0x0040200106482001beef
629 6         12 my $partial_bitstr = substr(to_str( $self->get_bitstr ),0,$self->get_prefixlen);
630 6         10 my $remain = $self->get_prefixlen % 8;
631 6 100       11 if($remain > 0) {
632 2         5 $partial_bitstr = $partial_bitstr . '0'x(8 - $remain);
633             }
634 6         7 return '0x00'.sprintf("%02x",$self->get_prefixlen).join('',map {unpack("H",pack("B4",$_))} ($partial_bitstr =~ /([01]{4})/g) );
  84         113  
635             }
636              
637             package IPv4Subnet;
638             $IPv4Subnet::VERSION = '0.207';
639 1     1   482 use Socket;
  1         3305  
  1         323  
640 1     1   5 use strict;
  1         0  
  1         14  
641 1     1   3 use Carp;
  1         1  
  1         33  
642 1     1   3 use warnings;
  1         1  
  1         19  
643 1     1   2 use Data::Dumper;
  1         1  
  1         615  
644              
645              
646             sub new {
647 35 50   35   326 defined ( my $class = shift ) or die "missing class";
648 35 50       48 defined ( my $str = shift ) or die "missing string";
649 35 50       150 my ( $ip , $length_n ) = ( $str =~ /^(\d+\.\d+\.\d+\.\d+)\/(\d+)$/ ) or croak "Cannot parse $str";
650 35         43 bless { ip_n => my_aton($ip) , length_n => $length_n } , $class ;
651             }
652              
653             sub new_from_start_stop {
654 1     1   4 $_[0]->new( $_[1].'/'.(32 - log( ( my_aton($_[1]) ^ my_aton($_[2]) ) + 1)/log(2)))
655             }
656              
657             sub to_string {
658 1     1   5 $_[0]->get_start_ip . '/' . $_[0]->get_length_n
659             }
660              
661             sub get_ip_n {
662 314     314   327 return $_[0]->{ip_n} ;
663             }
664              
665             sub get_start {
666 314     314   275 return $_[0]->get_ip_n & $_[0]->get_mask_n;
667             }
668              
669             sub get_stop {
670 262     262   237 return $_[0]->get_start + $_[0]->get_length - 1;
671             }
672              
673             sub get_start_ip {
674 4     4   7 return my_ntoa($_[0]->get_start);
675             }
676              
677             sub get_stop_ip {
678 3     3   5 return my_ntoa($_[0]->get_stop);
679             }
680              
681             sub get_length {
682 285     285   615 return 2**(32-$_[0]->get_length_n);
683             }
684              
685             sub enumerate {
686             # in 32-bit systems, this seems to fail with error:
687             # "Range iterator outside integer range"
688             #map { my_ntoa( $_ ) } ($_[0]->get_start .. $_[0]->get_stop)
689 1     1   1 my @ret;
690 1         2 for( my $i = $_[0]->get_start ; $i <= $_[0]->get_stop ; $i++ ) {
691 256         222 push @ret,my_ntoa( $i )
692             }
693             return @ret
694 1         45 }
695              
696             sub get_length_n {
697 928     928   1874 return $_[0]->{length_n};
698             }
699              
700             sub get_mask_n {
701 326 100   326   277 ($_[0]->get_length_n == 0 )?
702             0 : hex('0xffffffff') << ( 32 - $_[0]->get_length_n ) ;
703             }
704              
705             sub get_mask {
706 6     6   7 my_ntoa( $_[0]->get_mask_n );
707             }
708              
709             sub get_wildcard {
710 6     6   9 my_ntoa( ~ $_[0]->get_mask_n );
711             }
712              
713             sub my_aton {
714 82 50   82   206 defined ( my $aton_str = inet_aton( $_[0] ) ) or croak '$_[0] cannot be fed to inet_aton';
715 82         200 return unpack('N',$aton_str);
716             }
717              
718             sub my_ntoa {
719 275     275   924 return inet_ntoa(pack('N',$_[0]));
720             }
721              
722             sub position {
723 45     45   27 my $self = shift;
724 45 50       65 defined ( my $arg = shift ) or die "Incorrect call";
725 45         35 my $number = my_aton($arg);
726 45 50       58 $DEBUG && print STDERR "number is ",my_ntoa($number)," and start is ",my_ntoa($self->get_start)," and stop is ",my_ntoa($self->get_stop),"\n";
727 45         48 return $number - $self->get_start;
728             }
729              
730             sub contains {
731 19 100 66 19   213 return ( ($_[0]->position($_[1]) < $_[0]->get_length) && ( $_[0]->position($_[1]) >= 0 ) )? 1 : 0;
732             }
733              
734             sub calculate_compound_offset {
735 10 50   10   21 defined( my $address = shift ) or die 'missing address';
736 10 50       34 defined( my $blocks = shift ) or die 'missing block reference';
737            
738 10         10 my $offset = 0;
739 10         4 for my $block (@{$blocks}) {
  10         15  
740 12         33 my $subnet = IPv4Subnet->new($block);
741 12 100       14 if ($subnet->contains($address)) {
742 10         11 return ( $subnet->position($address) + $offset );
743             }
744             else {
745 2         4 $offset = $offset + $subnet->get_length;
746             }
747             }
748 0           die "Address $address does not belong to range:",join(',',@{$blocks});
  0            
749 0           return;
750             }
751              
752             =head1 AUTHOR
753              
754             Athanasios Douitsis C<< >>
755              
756             =head1 SUPPORT
757              
758             Please open a ticket at L.
759              
760             =head1 COPYRIGHT & LICENSE
761            
762             Copyright 2008-2015 Athanasios Douitsis, all rights reserved.
763            
764             This program is free software; you can use it
765             under the terms of Artistic License 2.0 which can be found at
766             http://www.perlfoundation.org/artistic_license_2_0
767            
768             =cut
769              
770             1;
771            
772