File Coverage

blib/lib/Regexp/Common/net.pm

Criterion	Covered	Total	%
statement	16	16	100.0
branch			n/a
condition			n/a
subroutine	7	7	100.0
pod	0	2	0.0
total	23	25	92.0

package Regexp::Common::net;

use 5.10.0;

use strict;
use warnings;
no  warnings 'syntax';

use Regexp::Common qw /pattern clean no_defaults/;

our $VERSION = '2017060201';


my %IPunit = (
    dec    => q{(?k:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})},
    oct    => q{(?k:[0-3]?[0-7]{1,2})},
    hex    => q{(?k:[0-9a-fA-F]{1,2})},
    bin    => q{(?k:[0-1]{1,8})},
    strict => q{(?k:2(?:5[0-5]?|[0-4][0-9]?|[6-9]?)|1[0-9]{0,2}|[3-9][0-9]?|0)},
);
my %MACunit = (
    %IPunit,
    hex => q{(?k:[0-9a-fA-F]{1,2})},
);

my %IPv6unit = (
    hex => q {(?k:[0-9a-f]{1,4})},
    HEX => q {(?k:[0-9A-F]{1,4})},
    HeX => q {(?k:[0-9a-fA-F]{1,4})},
);

sub dec {$_};
sub bin {oct "0b$_"}

my $IPdefsep   = '[.]';
my $MACdefsep  =  ':';
my $IPv6defsep =  ':';

pattern name   => [qw (net IPv4)],
        create => "(?k:$IPunit{dec}$IPdefsep$IPunit{dec}$IPdefsep" .
                      "$IPunit{dec}$IPdefsep$IPunit{dec})",
        ;

pattern name   => [qw (net MAC)],
        create => "(?k:" . join ($MACdefsep => ($MACunit{hex}) x 6) . ")",
        subs   => sub {
            $_ [1] = join ":" => map {sprintf "%02x" => hex}
                                 split /$MACdefsep/ => $_ [1]
                     if $_ [1] =~ /$_[0]/
        },
        ;

foreach my $type (qw /dec oct hex bin strict/) {
    pattern name   => [qw (net IPv4), $type, "-sep=$IPdefsep"],
            create => sub {my $sep = $_ [1] -> {-sep};
                           "(?k:$IPunit{$type}$sep$IPunit{$type}$sep" .
                               "$IPunit{$type}$sep$IPunit{$type})"
                      },
            ;

    pattern name   => [qw (net MAC), $type, "-sep=$MACdefsep"],
            create => sub {my $sep = $_ [1] -> {-sep};
                           "(?k:" . join ($sep => ($MACunit{$type}) x 6) . ")",
                      },
            subs   => sub {
                return if $] < 5.006 and $type eq 'bin';
                $_ [1] = join ":" => map {sprintf "%02x" => eval $type}
                                     $2, $3, $4, $5, $6, $7
                         if $_ [1] =~ $RE {net} {MAC} {$type}
                                          {-sep => $_ [0] -> {flags} {-sep}}
                                          {-keep};
            },
            ;

}


my %cache6;
pattern name   => [qw (net IPv6), "-sep=$IPv6defsep", "-style=HeX"],
        create => sub {
            my $style = $_ [1] {-style};
            my $sep   = $_ [1] {-sep};

            return $cache6 {$style, $sep} if $cache6 {$style, $sep};

            my @re;

            die "Impossible style '$style'\n" unless exists $IPv6unit {$style};

            #
            # Nothing missing
            #
            push @re => join $sep => ($IPv6unit {$style}) x 8;

            #
            # For "double colon" representations, at least 2 units must
            # be omitted, leaving us with at most 6 units. 0 units is also
            # possible. Note we can have at most one double colon.
            #
            for (my $l = 0; $l <= 6; $l ++) {
                #
                # We prefer to do longest match, so larger $r gets priority
                #
                for (my $r = 6 - $l; $r >= 0; $r --) {
                    #
                    # $l is the number of blocks left of the double colon,
                    # $r is the number of blocks left of the double colon,
                    # $m is the number of omitted blocks
                    #
                    my $m    = 8 - $l - $r;
                    my $patl = $l ? ($IPv6unit {$style} . $sep) x $l : $sep;
                    my $patr = $r ? ($sep . $IPv6unit {$style}) x $r : $sep;
                    my $patm = "(?k:)" x $m;
                    my $pat  = $patl . $patm . $patr;
                    push @re => "(?:$pat)";
                }
            }
            local $" = "|";
            $cache6 {$style, $sep} = qq /(?k:(?|@re))/;
        },
;


my $letter      =  "[A-Za-z]";
my $let_dig     =  "[A-Za-z0-9]";
my $let_dig_hyp = "[-A-Za-z0-9]";

# Domain names, from RFC 1035.
pattern name   => [qw (net domain -nospace= -rfc1101=)],
        create => sub {
            my $rfc1101 = exists $_ [1] {-rfc1101} &&
                        !defined $_ [1] {-rfc1101};

            my $lead = $rfc1101 ? "(?!$RE{net}{IPv4}(?:[.]|\$))$let_dig"
                                : $letter;

            if (exists $_ [1] {-nospace} && !defined $_ [1] {-nospace}) {
                return "(?k:$lead(?:(?:$let_dig_hyp){0,61}$let_dig)?" .
                       "(?:\\.$lead(?:(?:$let_dig_hyp){0,61}$let_dig)?)*)"
            }
            else {
                return "(?k: |(?:$lead(?:(?:$let_dig_hyp){0,61}$let_dig)?" .
                       "(?:\\.$lead(?:(?:$let_dig_hyp){0,61}$let_dig)?)*))"
            }
        },
        ;



1;

__END__