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

#!/usr/bin/perl
#===============================================================================
#      PODNAME:  Net::IP::Identifier::Binode
#     ABSTRACT:  A node in the binary tree
#
#       AUTHOR:  Reid Augustin (REID)
#        EMAIL:  [e-mail]
#      CREATED:  Mon Oct  6 10:20:33 PDT 2014
#===============================================================================

use 5.002;
use strict;
use warnings;

$DB::deep = 150;    # IPv6 needs 128 plus some headroom

package Net::IP::Identifier::Binode;
use Carp;
use Math::BigInt;
use Moo;
use namespace::clean;

our $VERSION = '0.111'; # VERSION

has zero => (
    is => 'rw',
    isa => \&isnode,
);
has one => (
    is => 'rw',
    isa => \&isnode,
);
has payload => (
    is => 'rw',
);

sub isnode {
    die if defined $_[0] and ref $_[0] ne __PACKAGE__;
}

sub bin_to_ip {
    my ($bin) = @_;

    my @results;
    my $max = length $bin;
    for (my $ii = 0; ; $ii++) {
        if ($ii % 8 == 0) {
            last if ($ii >= $max);
            push @results, 0;
        }
        my $b = $ii < $max ? substr($bin, $ii, 1) : 0;
        $results[-1] <<= 1;
        $results[-1] |= $b;
    }
    return join '.', @results;
}

our $path = Math::BigInt->new(0);
sub construct {
    my ($self, $path) = @_;

    my $node;
    $self->_follow(
        $path,
        0,
        sub {   # construction callback
            my ($self, $path, $level) = @_;

            if ($level < length $path) {
                if (substr($path, $level, 1)) {    # next step
                    $self->one($self->new) if (not $self->one);
                }
                else {
                    $self->zero($self->new) if (not $self->zero);
                }
            }
            else {
                $node = $self;  # when we reach the end
            }
            return 0;   # always continue
        }
    );
    return $node;
}

sub follow {
    my ($self, $path, $callback, @extra) = @_;

    croak "Need a code ref\n" if (not $callback or ref $callback ne 'CODE');
    return $self->_follow($path, 0, $callback, @extra);
}

sub _follow {
    no warnings 'recursion';    # IPv6 requires at least 128 levels
    my ($self, $path, $level, $callback, @extra) = @_;

    return if $callback->($self, $path, $level, @extra);

    return $self if ($level >= length $path); # end of the line

    if (substr($path, $level, 1)) {    # next step
        return $self->one->_follow($path, $level + 1, $callback, @extra) if ($self->one);
    }
    else {
        return $self->zero->_follow($path, $level + 1, $callback, @extra) if ($self->zero);
    }
    return; # no node at $path
}

sub traverse_width_first {
    my ($self, $callback, @extra) = @_;

    croak "Need a code ref\n" if (not $callback or ref $callback ne 'CODE');
    return $self->_traverse_width_first(0, $callback, @extra);
}

sub _traverse_width_first {
    no warnings 'recursion';    # IPv6 requires at least 128 levels
    my ($self, $level, $callback, @extra) = @_;

    return if $callback->($self, $level, @extra);

#$path <<= 1;
    $self->zero->_traverse_width_first($level + 1, $callback, @extra) if ($self->zero);
#$path |= 1;
    $self->one ->_traverse_width_first($level + 1, $callback, @extra) if ($self->one);
#$path >>= 1;
}

sub traverse_depth_first {
    my ($self, $callback, @extra) = @_;

    croak "Need a code ref\n" if (not $callback or ref $callback ne 'CODE');
    $self->_traverse_depth_first(0, $callback, @extra);
}

sub _traverse_depth_first {
    no warnings 'recursion';    # IPv6 requires at least 128 levels
    my ($self, $level, $callback, @extra) = @_;

    my $stop;
#print "path=", $path->as_hex, "\n";
#$path <<= 1;
    $stop = $self->zero->_traverse_depth_first($level + 1, $callback, @extra) if ($self->zero);
#$path |= 1;
    $stop = $self->one ->_traverse_depth_first($level + 1, $callback, @extra) if (not $stop and $self->one);
#$path >>= 1;

    $callback->($self, $level, @extra) if (not $stop);
}

1;

__END__