File Coverage

lib/Range/Merge.pm

Criterion	Covered	Total	%
statement	139	145	95.8
branch	29	36	80.5
condition	2	3	66.6
subroutine	15	16	93.7
pod	3	3	100.0
total	188	203	92.6

#!/usr/bin/perl

#
# Copyright (C) 2016-2019 Joelle Maslak
# All Rights Reserved - See License
#

package Range::Merge;
$Range::Merge::VERSION = '2.191190';
use strict;
use warnings;

use Range::Merge::Boilerplate 'script';

require Exporter;
our @ISA       = qw(Exporter);
our @EXPORT_OK = qw(merge merge_discrete merge_ipv4);

use List::Util qw(max);
use Net::CIDR;
use Socket;

# ABSTRACT: Merges ranges of data including subset/superset ranges



sub merge($ranges) {
    my $sorted = _sort($ranges);
    my $split  = [];
    _split( $sorted, $split );
    return _combine($split);
}


sub merge_discrete($values) {
    my $ranges = [];

    my $run;

    for my $num ( sort { $a <=> $b } @$values ) {
        if ( !defined $run ) {
            $run = [ $num, $num ];
            push @$ranges, $run;
        } else {
            if ( $run->[1] == $num ) {
                # Do nothing
            } elsif ( $run->[1] == $num - 1 ) {
                $run->[1] = $num;
            } else {
                $run = [ $num, $num ];
                push @$ranges, $run;
            }
        }
    }

    return $ranges;
}


sub merge_ipv4($cidr) {
    my $ranges = [];
    @$ranges = map { _cidr2range($_) } @$cidr;
    my $combined = merge($ranges);
    return _range2cidr($combined);
}

sub _cidr2range($cidr) {
    my ( $ip, @a ) = @$cidr;
    my ($range) = Net::CIDR::cidr2range($ip);
    my (@parts) = map { unpack( 'N', inet_aton($_) ) } split( /-/, $range );

    return [ @parts, @a ];
}

sub _range2cidr($ranges) {
    my @output;
    foreach my $range (@$ranges) {
        my ( $start, $end, @other ) = @$range;
        $start = inet_ntoa( pack( 'N', $start ) );
        $end   = inet_ntoa( pack( 'N', $end ) );
        foreach my $cidr ( Net::CIDR::range2cidr("$start-$end") ) {
            push @output, [ $cidr, @other ];
        }
    }
    return \@output;
}

# Sorts by starting address and then by reverse (less specific to more
# specific)
sub _sort($ranges) {
    my (@output) = sort { ( $a->[0] <=> $b->[0] ) || ( $b->[1] <=> $a->[0] ) } @$ranges;
    return \@output;
}

sub _merge($ranges) {
    my $split = [];
    _split( $ranges, $split );
    return _combine($split);
}

sub _combine($ranges) {
    my @output;

    my $last;
    foreach my $range (@$ranges) {
        if ( !defined($last) ) {
            $last = [@$range];
            next;
        }
        if ( ( $last->[1] == $range->[0] - 1 ) && ( scalar(@$last) == scalar(@$range) ) ) {
            my $nomatch;
            for ( my $i = 2; $i < scalar(@$range); $i++ ) {
                if ( $last->[$i] ne $range->[$i] ) {
                    $nomatch = 1;
                    last;
                }
            }
            if ($nomatch) {
                push @output, $last;
                $last = [@$range];
            } else {
                $last->[1] = $range->[1];
            }
        } else {
            push @output, $last;
            $last = [@$range];
        }
    }
    if ( defined($last) ) { push @output, $last }

    return \@output;
}

sub _split ( $ranges, $output, $stack = [] ) {
    # Termination condition
    return if scalar( $ranges->@* ) == 0;

    # We just repeatedly call _add_to_stack
    foreach my $range ( $ranges->@* ) {
        _add_to_stack( $range, $stack, $output );
    }

    # Return stack
    if ( scalar( $stack->@* ) ) {
        push $output->@*, $stack->@*;
    }

    return;
}

sub _add_to_stack ( $range, $stack, $output ) {
    if ( !scalar( $stack->@* ) ) {
        # Empty stack
        push $stack->@*, $range;
        return;
    }

    # We know the following:
    #
    # 1. The stack is sorted
    # 2. There are no overlapping elements
    #    2a. Thus we only have to split 1 element max
    # 3. The stack has at least one element

    my (@lstack) = grep { $_->[1] < $range->[0] } @$stack;
    my (@rstack) = grep { $_->[0] > $range->[1] } @$stack;
    my (@mid)    = grep { ( $_->[0] <= $range->[1] ) && ( $_->[1] >= $range->[0] ) } @$stack;

    # Clear stack
    @$stack = ();

    # Output the stuff completely to the left of the new range
    push @$output, @lstack;

    # Option 1 -> No middle element, so just add the range (and the
    # right stack) to the stack
    if ( !scalar(@mid) ) {
        push @$stack, $range, @rstack;
        return;
    }

    # We start with the left and right parts of the element that might
    # need to be split.
    my (@left)  = $mid[0]->@*;
    my (@right) = $mid[0]->@*;

    # Does the ele needing split start before the range?  If so, add the piece
    # needed to the output
    if ( $left[0] < $range->[0] ) {
        @left[1] = $range->[0] - 1;
        if ( $left[0] <= $left[1] ) {
            push @$output, \@left;
        }
    }

    # We need to add the range to the stack
    push @$stack, $range;

    # Does the ele needing split end after the range?  If so, add the
    # piece to the stack
    if ( $right[1] > $range->[1] ) {
        @right[0] = $range->[1] + 1;
        if ( $right[0] <= $right[1] ) {
            push @$stack, \@right;
        }
    }

    push @$stack, @rstack;

    return;
}

1;

__END__