view release on metacpan or  search on metacpan

lib/Net/IPAddress/Util/Collection.pm  view on Meta::CPAN

package Net::IPAddress::Util::Collection;

use strict;
use warnings;
use 5.012;

require Net::IPAddress::Util;
require Net::IPAddress::Util::Collection::Tie;
require Net::IPAddress::Util::Range;

our $VERSION = '5.001';

sub new {
  my $class    = ref($_[0]) ? ref(shift()) : shift;
  my @contents = @_;
  my @o;
  tie @o, 'Net::IPAddress::Util::Collection::Tie', \@contents;
  return bless \@o => $class;
}

sub sorted {
  my $self = shift;
  # In theory, a raw radix sort is O(N), which beats Perl's O(N log N) by
  # a fair margin. However, it _does_ discard duplicates, so ymmv.
  # FIXME Should we sort by hi, lo instead of lo, hi?
  my $from = [ map { [ unpack('C32', $_->{ lower }->{ address } . $_->{ upper }->{ address }) ] } @$self ];
  my $to;
  for (my $i = 31; $i >= 0; $i--) {
    $to = [];
    for my $card (@$from) {
      push @{$to->[ $card->[ $i ] ]}, $card;
    }
    $from = [ map { @{$_ // []} } @$to ];
  }
  my @rv = map {
    my $n = $_;
    my $l = Net::IPAddress::Util->new([@{$n}[0 .. 15]]);
    my $r = Net::IPAddress::Util->new([@{$n}[16 .. 31]]);
    my $x = Net::IPAddress::Util::Range->new({ lower => $l, upper => $r });
    $x;
  } @$from;
  return $self->new(@rv);
}

sub compacted {
  my $self = shift;
  my @sorted = @{$self->sorted()};
  my @compacted;
  my $elem;
  while ($elem = shift @sorted) {
    if (scalar @sorted and $elem->{ upper } >= $sorted[0]->{ lower } - 1) {
      $elem = ref($elem)->new({ lower => $elem->{ lower }, upper => $sorted[0]->{ upper } });
      shift @sorted;
      redo;
    }
    else {
      push @compacted, $elem;
    }
  }
  return $self->new(@compacted);
}

sub tight {
  my $self = shift;
  my @tight;
  map { push @tight, @{$_->tight()} } @{$self->compacted()};
  return $self->new(@tight);
}

sub as_cidrs {
  my $self = shift;
  return map { $_->as_cidr() } grep { eval { $_->{ lower } } } @$self;
}

sub as_netmasks {
  my $self = shift;
  return map { $_->as_netmask() } grep { eval { $_->{ lower } } } @$self;
}