File Coverage

blib/lib/Net/IP/Identifier/Binode.pm
Criterion Covered Total %
statement 59 78 75.6
branch 26 44 59.0
condition 3 15 20.0
subroutine 17 20 85.0
pod 4 6 66.6
total 109 163 66.8


line stmt bran cond sub pod time code
1             #!/usr/bin/perl
2             #===============================================================================
3             # PODNAME: Net::IP::Identifier::Binode
4             # ABSTRACT: A node in the binary tree
5             #
6             # AUTHOR: Reid Augustin (REID)
7             # EMAIL: reid@hellosix.com
8             # CREATED: Mon Oct 6 10:20:33 PDT 2014
9             #===============================================================================
10              
11 4     4   897 use 5.002;
  4         14  
  4         195  
12 4     4   38 use strict;
  4         7  
  4         196  
13 4     4   64 use warnings;
  4         5  
  4         286  
14              
15             $DB::deep = 150; # IPv6 needs 128 plus some headroom
16              
17             package Net::IP::Identifier::Binode;
18 4     4   32 use Carp;
  4         8  
  4         352  
19 4     4   5492 use Math::BigInt;
  4         26282  
  4         46  
20 4     4   21819 use Moo;
  4         16857  
  4         37  
21 4     4   4800 use namespace::clean;
  4         40158  
  4         23  
22              
23             our $VERSION = '0.111'; # VERSION
24              
25             has zero => (
26             is => 'rw',
27             isa => \&isnode,
28             );
29             has one => (
30             is => 'rw',
31             isa => \&isnode,
32             );
33             has payload => (
34             is => 'rw',
35             );
36              
37             sub isnode {
38 12589 50 33 12589 0 1186244 die if defined $_[0] and ref $_[0] ne __PACKAGE__;
39             }
40              
41             sub bin_to_ip {
42 0     0 0 0 my ($bin) = @_;
43              
44 0         0 my @results;
45 0         0 my $max = length $bin;
46 0         0 for (my $ii = 0; ; $ii++) {
47 0 0       0 if ($ii % 8 == 0) {
48 0 0       0 last if ($ii >= $max);
49 0         0 push @results, 0;
50             }
51 0 0       0 my $b = $ii < $max ? substr($bin, $ii, 1) : 0;
52 0         0 $results[-1] <<= 1;
53 0         0 $results[-1] |= $b;
54             }
55 0         0 return join '.', @results;
56             }
57              
58             our $path = Math::BigInt->new(0);
59             sub construct {
60 1519     1519 1 13291 my ($self, $path) = @_;
61              
62 1519         1716 my $node;
63             $self->_follow(
64             $path,
65             0,
66             sub { # construction callback
67 34498     34498   35667 my ($self, $path, $level) = @_;
68              
69 34498 100       59056 if ($level < length $path) {
70 32979 100       52060 if (substr($path, $level, 1)) { # next step
71 13766 100       291007 $self->one($self->new) if (not $self->one);
72             }
73             else {
74 19213 100       391385 $self->zero($self->new) if (not $self->zero);
75             }
76             }
77             else {
78 1519         2294 $node = $self; # when we reach the end
79             }
80 34498         275629 return 0; # always continue
81             }
82 1519         12722 );
83 1519         66713 return $node;
84             }
85              
86             sub follow {
87 50     50 1 1951 my ($self, $path, $callback, @extra) = @_;
88              
89 50 50 33     482 croak "Need a code ref\n" if (not $callback or ref $callback ne 'CODE');
90 50         192 return $self->_follow($path, 0, $callback, @extra);
91             }
92              
93             sub _follow {
94 4     4   2342 no warnings 'recursion'; # IPv6 requires at least 128 levels
  4         10  
  4         903  
95 36645     36645   1037533 my ($self, $path, $level, $callback, @extra) = @_;
96              
97 36645 50       59224 return if $callback->($self, $path, $level, @extra);
98              
99 36645 100       85939 return $self if ($level >= length $path); # end of the line
100              
101 35118 100       73005 if (substr($path, $level, 1)) { # next step
102 13989 100       293721 return $self->one->_follow($path, $level + 1, $callback, @extra) if ($self->one);
103             }
104             else {
105 21129 100       439792 return $self->zero->_follow($path, $level + 1, $callback, @extra) if ($self->zero);
106             }
107 42         1482 return; # no node at $path
108             }
109              
110             sub traverse_width_first {
111 21     21 1 40 my ($self, $callback, @extra) = @_;
112              
113 21 50 33     166 croak "Need a code ref\n" if (not $callback or ref $callback ne 'CODE');
114 21         102 return $self->_traverse_width_first(0, $callback, @extra);
115             }
116              
117             sub _traverse_width_first {
118 4     4   21 no warnings 'recursion'; # IPv6 requires at least 128 levels
  4         6  
  4         630  
119 1317     1317   35380 my ($self, $level, $callback, @extra) = @_;
120              
121 1317 100       2760 return if $callback->($self, $level, @extra);
122              
123             #$path <<= 1;
124 1307 100       25934 $self->zero->_traverse_width_first($level + 1, $callback, @extra) if ($self->zero);
125             #$path |= 1;
126 1307 100       28331 $self->one ->_traverse_width_first($level + 1, $callback, @extra) if ($self->one);
127             #$path >>= 1;
128             }
129              
130             sub traverse_depth_first {
131 0     0 1   my ($self, $callback, @extra) = @_;
132              
133 0 0 0       croak "Need a code ref\n" if (not $callback or ref $callback ne 'CODE');
134 0           $self->_traverse_depth_first(0, $callback, @extra);
135             }
136              
137             sub _traverse_depth_first {
138 4     4   22 no warnings 'recursion'; # IPv6 requires at least 128 levels
  4         5  
  4         472  
139 0     0     my ($self, $level, $callback, @extra) = @_;
140              
141 0           my $stop;
142             #print "path=", $path->as_hex, "\n";
143             #$path <<= 1;
144 0 0         $stop = $self->zero->_traverse_depth_first($level + 1, $callback, @extra) if ($self->zero);
145             #$path |= 1;
146 0 0 0       $stop = $self->one ->_traverse_depth_first($level + 1, $callback, @extra) if (not $stop and $self->one);
147             #$path >>= 1;
148              
149 0 0         $callback->($self, $level, @extra) if (not $stop);
150             }
151              
152             1;
153              
154             __END__