File Coverage

blib/lib/NetAddr/MAC.pm

Criterion	Covered	Total	%
statement	285	450	63.3
branch	109	268	40.6
condition	30	53	56.6
subroutine	62	69	89.8
pod	54	54	100.0
total	540	894	60.4

#!/bin/false
# ABSTRACT: MAC hardware address functions and object (EUI48 and EUI64)

use strict;
use warnings;
use v5.10;
package NetAddr::MAC;
$NetAddr::MAC::VERSION = '0.99';

use Carp qw( croak );
use Exporter 'import';
use List::Util qw( first );

use constant EUI48LENGTHHEX => 12;
use constant EUI48LENGTHDEC => 6;
use constant EUI64LENGTHHEX => 16;
use constant EUI64LENGTHDEC => 8;

our %EXPORT_TAGS;

%EXPORT_TAGS = (
    all => [
        qw(
          mac_is_eui48     mac_is_eui64
          mac_is_unicast   mac_is_multicast
          mac_is_broadcast mac_is_vrrp
          mac_is_vrrp4     mac_is_vrrp6
          mac_is_hsrp      mac_is_hsrp2
          mac_is_msnlb
          mac_is_local     mac_is_universal
          mac_as_basic     mac_as_sun
          mac_as_microsoft mac_as_cisco
          mac_as_bpr       mac_as_ieee
          mac_as_ipv6_suffix
          mac_as_tokenring mac_as_singledash
          mac_as_pgsql
          )
    ],
    properties => [
        qw(
          mac_is_eui48     mac_is_eui64
          mac_is_unicast   mac_is_multicast
          mac_is_broadcast mac_is_vrrp
          mac_is_vrrp4     mac_is_vrrp6
          mac_is_hsrp      mac_is_hsrp2
          mac_is_msnlb
          mac_is_local     mac_is_universal
          )
    ],
    normals => [
        qw(
          mac_as_basic     mac_as_sun
          mac_as_microsoft mac_as_cisco
          mac_as_bpr       mac_as_ieee
          mac_as_ipv6_suffix
          mac_as_tokenring mac_as_singledash
          mac_as_pgsql
          )
    ],
);

Exporter::export_ok_tags( keys %EXPORT_TAGS );


sub new {

    my ( $p, @q ) = @_;
    my $c = ref($p) || $p;
    my $self = bless {}, $c;

    # clear the errstr, see also RT96045
    $NetAddr::MAC::errstr = undef;

    unless (@q) {
        my $e = q|Please provide a mac address|;
        croak "$e\n" if $NetAddr::MAC::die_on_error;
        $NetAddr::MAC::errstr = $e;
        return
    }

    # massage a single argument into a mac argument if needed
    $self->_init( @q % 2 ? ( mac => shift @q, @q ) : @q )
      or return;

    return $self

}

{

    my $_die;

    sub _init {

        my ( $self, %args ) = @_;

        if ( defined $args{die_on_error} ) {
            $self->{_die}++ if $args{die_on_error};
        }
        else {
            $self->{_die}++ if $NetAddr::MAC::die_on_error;
        }

        $_die++ if $self->{_die};

        $self->{original} = $args{mac};

        if ($args{mac} =~ m/^(\d+)\#(.+)$/ ) {
            $self->{priority} = $1;
            $args{mac} = $2;
        }

        $self->{mac} = _mac_to_integers( $args{mac} );

        unless ( $self->{mac} ) {
            croak $NetAddr::MAC::errstr . "\n" if $self->{_die};
            return
        }

        if (defined $self->{priority}) {
            if ($args{priority} and $args{priority} != $self->{priority}) {
                my $e = "Conflicting priority in '$self->{original}' and priority argument $args{priority}";
                croak "$e\n" if $self->{_die};
                $NetAddr::MAC::errstr = $e;
                return
            }
        }
        else {
            $self->{priority} = $args{priority} || 0;
        }

        # check none of the list elements are empty
        if (first { not defined $_ or 0 == length $_} @{$self->{mac}}) {
            my $e = "Invalid MAC format '$self->{original}'";
            croak "$e\n" if $self->{_die};
            $NetAddr::MAC::errstr = $e;
            return
        }

        return 1

    }

    sub _mac_to_integers {

        my $mac = shift;
        my $e;

        for (1) {

            unless ($mac) {
                $e = 'Please provide a mac address';
                last;
            }

            # be nice, strip leading and trailing whitespace
            $mac =~ s/^\s+//;
            $mac =~ s/\s+$//;

            $mac =~ s{^1,\d,}{}
              ; # blindly remove the prefix from bpr, we could check that \d is the actual length, but oh well

            # avoid matching ipv6
            last if $mac =~ m/[a-f0-9]{1,4}:[a-f0-9]{1,4}::([a-f0-9]{1,4})?/i;
            last if $mac =~ m/[a-f0-9]{1,4}::[a-f0-9]{1,4}:[a-f0-9]{1,4}/i;

            my @parts = grep { length } split( /[^a-z0-9]+/ix, $mac );

            # anything other than hex...
            last if ( first { m{[^a-f0-9]}i } @parts );

            # resolve wierd things like aabb.cc.00.11.22 or 11.22.33.aabbcc

            @parts = map {
                my $o = $_;
                (length($o) % 2) == 0 ? $o =~ m/(..)/g
                                      : $o
                } @parts;

            # 12 characters for EUI48, 16 for EUI64
            if (
                @parts == 1
                && (   length $parts[0] == EUI48LENGTHHEX
                    || length $parts[0] == EUI64LENGTHHEX )
              )
            {    # 0019e3010e72
                local $_ = shift(@parts);
                while (m{([a-f0-9]{2})}igx) { push( @parts, $1 ) }
                return [ map { hex($_) } @parts ]
            }

            # 00:19:e3:01:0e:72
            if ( @parts == EUI48LENGTHDEC || @parts == EUI64LENGTHDEC ) {
                return [ map { hex($_) } @parts ]
            }

            # 0019:e301:0e72
            if ( @parts == EUI48LENGTHDEC / 2 || @parts == EUI64LENGTHDEC / 2 )
            {
                # it would be nice to accept no leading 0's but this gives
                # problems detecting broken formatted macs.
                # cisco doesnt drop leading zeros so lets go for the least
                # edgey of the edge cases.
                last if (first {length $_ < 4} @parts);

                return [
                    map {
                        m{^ ([a-f0-9]{2}) ([a-f0-9]{2}) $}ix
                          && ( hex($1), hex($2) )
                    } @parts
                ];
            }

            last

        } # just so we can jump out

        $e ||= "Invalid MAC format '$mac'";

        if ( defined $_die ) {
            croak "$e\n" if $_die;
        }
        elsif ($NetAddr::MAC::die_on_error) {
            croak "$e\n";
        }

        $NetAddr::MAC::errstr = $e;

        return
    }

}


sub random {

    my ( $p, @q ) = @_;
    my $c = ref($p) || $p;
    my $self = bless {}, $c;

    # clear the errstr, see also RT96045
    $NetAddr::MAC::errstr = undef;

    unless (@q) {
        my $e = q|Please provide an oui prefix|;
        croak "$e\n" if $NetAddr::MAC::die_on_error;
        $NetAddr::MAC::errstr = $e;
        return
    }

    die 'TODO';

    # massage a single argument into a mac argument if needed
    $self->_init( @q % 2 ? ( oui => shift @q, @q ) : @q )
      or return;

    return $self

}


sub original {

    my $self = shift;
    return $self->{original}

}


sub oui {

    my $self = shift;
    return uc join(
        q{-},
            map { sprintf( '%02x', $_ ) }
            @{ $self->{mac} }[0 .. 2]
        );

}


sub errstr {

    my $self = shift;
    return $NetAddr::MAC::errstr unless ref $self;
    return $self->{_errstr}

}


sub is_eui48 {
    my $self = shift;
    return scalar @{ $self->{mac} } == EUI48LENGTHDEC
}


sub is_eui64 {
    my $self = shift;
    return scalar @{ $self->{mac} } == EUI64LENGTHDEC
}


sub is_multicast {
    my $self = shift;

    return ($self->{mac}->[0] & 1) && ! is_broadcast($self);
}



sub is_broadcast {
    my $self = shift;

    for (@{$self->{mac}}) {
        return 0 if $_ != 255
    }
    return 1
}


sub is_vrrp {
    my $self = shift;

    return is_vrrp4( $self ) || is_vrrp6( $self );
}


sub is_vrrp4 {
    my $self = shift;

    return
        is_eui48($self) &&
        $self->{mac}->[0] == 0 &&
        $self->{mac}->[1] == 0 &&
        $self->{mac}->[2] == hex('0x5e') &&
        $self->{mac}->[3] == 0 &&
        $self->{mac}->[4] == 1;

}


sub is_vrrp6 {
    my $self = shift;

    return
        is_eui48($self) &&
        $self->{mac}->[0] == 0 &&
        $self->{mac}->[1] == 0 &&
        $self->{mac}->[2] == hex('0x5e') &&
        $self->{mac}->[3] == 0 &&
        $self->{mac}->[4] == 2;

}


sub is_hsrp {
    my $self = shift;

    return
        is_eui48($self) &&
        $self->{mac}->[0] == 0 &&
        $self->{mac}->[1] == 0 &&
        $self->{mac}->[2] == hex('0xc') &&
        $self->{mac}->[3] == 7 &&
        $self->{mac}->[4] == hex('0xac');

}


sub is_hsrp2 {
    my $self = shift;

    return
        is_eui48($self) &&
        $self->{mac}->[0] == 0 &&
        $self->{mac}->[1] == 0 &&
        $self->{mac}->[2] == hex('0xc') &&
        $self->{mac}->[3] == hex('0x9f');
        $self->{mac}->[4] >= 240; # 0xFX

}



sub is_msnlb {
    my $self = shift;

    return
        is_eui48($self) &&
        ($self->{mac}->[0] == 2
            || $self->{mac}->[0] == 3) &&
        $self->{mac}->[1] == hex('0xbf')

}


sub is_unicast {
    my $self = shift;
    return ! ($self->{mac}->[0] & 1);
}


sub is_local {
    my $self = shift;
    return $self->{mac}->[0] & 2
}


sub is_universal {
    my $self = shift;
    return !is_local($self)
}


sub as_basic {
    my $self = shift;
    return join( q{}, map { sprintf( '%02x', $_ ) } @{ $self->{mac} } )
}


sub as_bridge_id {
    my $self = shift;
    return $self->{priority}
        . '#'
        . $self->as_cisco;
}


sub as_bpr {
    my $self = shift;
    return
        q{1,}
      . scalar @{ $self->{mac} } . q{,}
      . join( q{:}, map { sprintf( '%02x', $_ ) } @{ $self->{mac} } );
}


sub as_cisco {
    my $self = shift;
    return join( q{.},
        map { m{([a-f0-9]{4})}gxi }
          join( q{}, map { sprintf( '%02x', $_ ) } @{ $self->{mac} } ) )
}


sub as_ieee {
    my $self = shift;
    return join( q{:}, map { sprintf( '%02x', $_ ) } @{ $self->{mac} } )
}


sub as_ipv6_suffix {

    my $self = shift;
    my @tmpmac;

    # be slightly evil here, so that hashrefs and objects work
    if ( is_eui48($self) ) {

        # save this for later
        @tmpmac = @{ $self->{mac} };

        to_eui64($self);

    }

    my @suffix = ( @{ $self->{mac} }[0] ^ 0x02, @{ $self->{mac} }[ 1 .. 7 ] );

    # restore the eui48 if needed
    $self->{mac} = \@tmpmac if @tmpmac;

    return join(
        q{:},
        map {
            my $i = $_;
            $i *= 2;
            sprintf( '%02x%02x', $suffix[$i], $suffix[ $i + 1 ] )
        } 0 .. 3
    );
}


sub as_microsoft {
    my $self = shift;
    return join( q{-}, map { sprintf( '%02x', $_ ) } @{ $self->{mac} } )
}


sub as_pgsql {
    my $self = shift;

    # there may be a better way to do this
    my $len = scalar @{ $self->{mac} };
    return join(
        q{:},
        join( '',
            map { sprintf( '%02x', $_ ) }
              @{ $self->{mac} }[ 0 .. ( $len / 2 - 1 ) ] ),
        join( '',
            map { sprintf( '%02x', $_ ) }
              @{ $self->{mac} }[ ( $len / 2 ) .. ( $len - 1 ) ] ),
    );
}


sub as_singledash {
    my $self = shift;

    # there may be a better way to do this
    my $len = scalar @{ $self->{mac} };
    return join(
        q{-},
        join( '',
            map { sprintf( '%02x', $_ ) }
              @{ $self->{mac} }[ 0 .. ( $len / 2 - 1 ) ] ),
        join( '',
            map { sprintf( '%02x', $_ ) }
              @{ $self->{mac} }[ ( $len / 2 ) .. ( $len - 1 ) ] ),
    );
}


sub as_sun {
    my $self = shift;
    return join( q{-}, map { sprintf( '%01x', $_ ) } @{ $self->{mac} } )
}


sub as_tokenring {

    my $self = shift;

    return join '-', map {
        my $byte = $_;
        my $rev  = 0;
        $rev = ($rev << 1) | ($byte & 1), $byte >>= 1 for 1..8;
        sprintf '%02x', $rev
    } @{ $self->{mac} };
}


sub to_eui48 {

    my $self = shift;

    # be slightly evil here, so that hashrefs and objects work
    if ( is_eui64($self) ) {
        if ( @{ $self->{mac} }[3] == 0xff
            and
            ( @{ $self->{mac} }[4] == 0xff or @{ $self->{mac} }[4] == 0xfe ) )
        {

            # convert to eui-48
            $self->{mac} = [ @{ $self->{mac} }[ 0 .. 2, 5 .. 7 ] ];
        }
        else {
            my $e = 'eui-64 address is not derived from an eui-48 address';
            croak "$e\n" if $self->{_die};
            $self->{_errstr} = $e;
            return
        }
    }

    return 1
}


sub to_eui64 {

    my $self = shift;

    # be slightly evil here so that hashrefs and objects work
    if ( is_eui48($self) ) {

        # convert to EUI64
        $self->{mac} = [
            @{ $self->{mac} }[ 0 .. 2 ],
            0xff,
            0xfe,
            @{ $self->{mac} }[ 3 .. 5 ]
        ];

    }
    else { return }

    return 1
}


sub mac_is_eui48 {

    my $mac = shift;
    croak 'please use is_eui48'
      if ref $mac eq __PACKAGE__;
    if ( ref $mac ) {
        my $e = 'argument must be a string';
        croak "$e\n" if $NetAddr::MAC::die_on_error;
        $NetAddr::MAC::errstr = $e;
        return
    }

    $mac = _mac_to_integers($mac) or return;
    return is_eui48( { mac => $mac } )

}


sub mac_is_eui64 {

    my $mac = shift;
    croak 'please use is_eui64'
      if ref $mac eq __PACKAGE__;
    if ( ref $mac ) {
        my $e = 'argument must be a string';
        croak "$e\n" if $NetAddr::MAC::die_on_error;
        $NetAddr::MAC::errstr = $e;
        return
    }

    $mac = _mac_to_integers($mac) or return;
    return is_eui64( { mac => $mac } )

}


sub mac_is_multicast {

    my $mac = shift;
    croak 'please use is_multicast'
      if ref $mac eq __PACKAGE__;
    if ( ref $mac ) {
        my $e = 'argument must be a string';
        croak "$e\n" if $NetAddr::MAC::die_on_error;
        $NetAddr::MAC::errstr = $e;
        return
    }

    $mac = _mac_to_integers($mac) or return;
    return is_multicast( { mac => $mac } )

}



sub mac_is_broadcast {

    my $mac = shift;
    croak 'please use is_broadcast'
      if ref $mac eq __PACKAGE__;
    if ( ref $mac ) {
        my $e = 'argument must be a string';
        croak "$e\n" if $NetAddr::MAC::die_on_error;
        $NetAddr::MAC::errstr = $e;
        return
    }

    $mac = _mac_to_integers($mac) or return;
    return is_broadcast( { mac => $mac } )

}


sub mac_is_unicast {

    my $mac = shift;
    croak 'please use is_unicast'
      if ref $mac eq __PACKAGE__;
    if ( ref $mac ) {
        my $e = 'argument must be a string';
        croak "$e\n" if $NetAddr::MAC::die_on_error;
        $NetAddr::MAC::errstr = $e;
        return
    }

    $mac = _mac_to_integers($mac) or return;
    return is_unicast( { mac => $mac } )

}


sub mac_is_vrrp {

    my $mac = shift;
    croak 'please use is_vrrp'
      if ref $mac eq __PACKAGE__;
    if ( ref $mac ) {
        my $e = 'argument must be a string';
        croak "$e\n" if $NetAddr::MAC::die_on_error;
        $NetAddr::MAC::errstr = $e;

        return
    }

    $mac = _mac_to_integers($mac) or return;
    return is_vrrp( { mac => $mac } )

}


sub mac_is_vrrp4 {

    my $mac = shift;
    croak 'please use is_vrrp4'
      if ref $mac eq __PACKAGE__;
    if ( ref $mac ) {
        my $e = 'argument must be a string';
        croak "$e\n" if $NetAddr::MAC::die_on_error;
        $NetAddr::MAC::errstr = $e;

        return
    }

    $mac = _mac_to_integers($mac) or return;
    return is_vrrp4( { mac => $mac } )

}


sub mac_is_vrrp6 {

    my $mac = shift;
    croak 'please use is_vrrp6'
      if ref $mac eq __PACKAGE__;
    if ( ref $mac ) {
        my $e = 'argument must be a string';
        croak "$e\n" if $NetAddr::MAC::die_on_error;
        $NetAddr::MAC::errstr = $e;

        return
    }

    $mac = _mac_to_integers($mac) or return;
    return is_vrrp6( { mac => $mac } )

}


sub mac_is_hsrp {

    my $mac = shift;
    croak 'please use is_hsrp'
      if ref $mac eq __PACKAGE__;
    if ( ref $mac ) {
        my $e = 'argument must be a string';
        croak "$e\n" if $NetAddr::MAC::die_on_error;
        $NetAddr::MAC::errstr = $e;

        return
    }

    $mac = _mac_to_integers($mac) or return;
    return is_hsrp( { mac => $mac } )

}


sub mac_is_hsrp2 {

    my $mac = shift;
    croak 'please use is_hsrp2'
      if ref $mac eq __PACKAGE__;
    if ( ref $mac ) {
        my $e = 'argument must be a string';
        croak "$e\n" if $NetAddr::MAC::die_on_error;
        $NetAddr::MAC::errstr = $e;

        return
    }

    $mac = _mac_to_integers($mac) or return;
    return is_hsrp2( { mac => $mac } )

}


sub mac_is_msnlb {

    my $mac = shift;
    croak 'please use is_msnlb'
      if ref $mac eq __PACKAGE__;
    if ( ref $mac ) {
        my $e = 'argument must be a string';
        croak "$e\n" if $NetAddr::MAC::die_on_error;
        $NetAddr::MAC::errstr = $e;

        return
    }

    $mac = _mac_to_integers($mac) or return;
    return is_msnlb( { mac => $mac } )

}


sub mac_is_local {

    my $mac = shift;
    croak 'please use is_local'
      if ref $mac eq __PACKAGE__;
    if ( ref $mac ) {
        my $e = 'argument must be a string';
        croak "$e\n" if $NetAddr::MAC::die_on_error;
        $NetAddr::MAC::errstr = $e;
        return
    }

    $mac = _mac_to_integers($mac) or return;
    return is_local( { mac => $mac } )

}


sub mac_is_universal {

    my $mac = shift;
    croak 'please use is_universal'
      if ref $mac eq __PACKAGE__;
    if ( ref $mac ) {
        my $e = 'argument must be a string';
        croak "$e\n" if $NetAddr::MAC::die_on_error;
        $NetAddr::MAC::errstr = $e;
        return
    }

    $mac = _mac_to_integers($mac) or return;
    return is_universal( { mac => $mac } )

}


sub mac_as_basic {

    my $mac = shift;
    croak 'please use as_basic'
      if ref $mac eq __PACKAGE__;
    if ( ref $mac ) {
        my $e = 'argument must be a string';
        croak "$e\n" if $NetAddr::MAC::die_on_error;
        $NetAddr::MAC::errstr = $e;
        return
    }

    $mac = _mac_to_integers($mac) or return;
    return as_basic( { mac => $mac } )

}


sub mac_as_bpr {

    my $mac = shift;
    croak 'please use as_basic'
      if ref $mac eq __PACKAGE__;
    if ( ref $mac ) {
        my $e = 'argument must be a string';
        croak "$e\n" if $NetAddr::MAC::die_on_error;
        $NetAddr::MAC::errstr = $e;
        return
    }

    $mac = _mac_to_integers($mac) or return;
    return as_bpr( { mac => $mac } )

}


sub mac_as_cisco {

    my $mac = shift;
    croak 'please use as_cisco'
      if ref $mac eq __PACKAGE__;
    if ( ref $mac ) {
        my $e = 'argument must be a string';
        croak "$e\n" if $NetAddr::MAC::die_on_error;
        $NetAddr::MAC::errstr = $e;
        return
    }

    $mac = _mac_to_integers($mac) or return;
    return as_cisco( { mac => $mac } )

}


sub mac_as_ieee {

    my $mac = shift;
    croak 'please use as_ieee'
      if ref $mac eq __PACKAGE__;
    if ( ref $mac ) {
        my $e = 'argument must be a string';
        croak "$e\n" if $NetAddr::MAC::die_on_error;
        $NetAddr::MAC::errstr = $e;
        return
    }

    $mac = _mac_to_integers($mac) or return;
    return as_ieee( { mac => $mac } )

}


sub mac_as_ipv6_suffix {

    my $mac = shift;
    croak 'please use as_ipv6_suffix'
      if ref $mac eq __PACKAGE__;
    if ( ref $mac ) {
        my $e = 'argument must be a string';
        croak "$e\n" if $NetAddr::MAC::die_on_error;
        $NetAddr::MAC::errstr = $e;
        return
    }

    $mac = _mac_to_integers($mac) or return;
    return as_ipv6_suffix( { mac => $mac } )

}


sub mac_as_microsoft {

    my $mac = shift;

    croak 'please use as_microsoft'
      if ref $mac eq __PACKAGE__;
    if ( ref $mac ) {
        my $e = 'argument must be a string';
        croak "$e\n" if $NetAddr::MAC::die_on_error;
        $NetAddr::MAC::errstr = $e;
        return
    }

    $mac = _mac_to_integers($mac) or return;
    return as_microsoft( { mac => $mac } )

}


sub mac_as_pgsql {

    my $mac = shift;

    croak 'please use as_pgsql'
      if ref $mac eq __PACKAGE__;
    if ( ref $mac ) {
        my $e = 'argument must be a string';
        croak "$e\n" if $NetAddr::MAC::die_on_error;
        $NetAddr::MAC::errstr = $e;
        return
    }

    $mac = _mac_to_integers($mac) or return;
    return as_pgsql( { mac => $mac } )

}


sub mac_as_singledash {

    my $mac = shift;

    croak 'please use as_singledash'
      if ref $mac eq __PACKAGE__;
    if ( ref $mac ) {
        my $e = 'argument must be a string';
        croak "$e\n" if $NetAddr::MAC::die_on_error;
        $NetAddr::MAC::errstr = $e;
        return
    }

    $mac = _mac_to_integers($mac) or return;
    return as_singledash( { mac => $mac } )

}


sub mac_as_sun {

    my $mac = shift;

    croak 'please use as_sun'
      if ref $mac eq __PACKAGE__;
    if ( ref $mac ) {
        my $e = 'argument must be a string';
        croak "$e\n" if $NetAddr::MAC::die_on_error;
        $NetAddr::MAC::errstr = $e;
        return
    }

    $mac = _mac_to_integers($mac) or return;
    return as_sun( { mac => $mac } )

}


sub mac_as_tokenring {

    my $mac = shift;

    croak 'please use as_tokenring'
      if ref $mac eq __PACKAGE__;
    if ( ref $mac ) {
        my $e = 'argument must be a string';
        croak "$e\n" if $NetAddr::MAC::die_on_error;
        $NetAddr::MAC::errstr = $e;
        return
    }

    $mac = _mac_to_integers($mac) or return;
    return as_tokenring( { mac => $mac } )

}


1;

__END__