File Coverage

blib/lib/NetAddr/MAC.pm

Criterion	Covered	Total	%
statement	272	417	65.2
branch	103	244	42.2
condition	23	44	52.2
subroutine	59	65	90.7
pod	49	49	100.0
total	506	819	61.7

#!/bin/false
# ABSTRACT: MAC address functions and object

use strict;
use warnings;
package NetAddr::MAC;
$NetAddr::MAC::VERSION = '0.96';

use Carp qw( croak );
use List::Util qw( first );

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

use constant ETHER2TOKEN => (
## see also http://www-01.ibm.com/support/docview.wss?uid=nas114157020a771b25d862567250003b62c
## note this table is rotated compared to the above link,
## so that the hex values line up as a linear array :)
## 0  1  2  3  4  5  6  7  8  9  a  b  c  d  e  f
    qw(00 80 40 c0 20 a0 60 e0 10 90 50 d0 30 b0 70 f0),    # 0
    qw(08 88 48 c8 28 a8 68 e8 18 98 58 d8 38 b8 78 f8),    # 1
    qw(04 84 44 c4 24 a4 64 e4 14 94 54 d4 34 b4 74 f4),    # 2
    qw(0c 8c 4c cc 2c ac 6c ec 1c 9c 5c dc 3c bc 7c fc),    # 3
    qw(02 82 42 c2 22 a2 62 e2 12 92 52 d2 32 b2 72 f2),    # 4
    qw(0a 8a 4a ca 2a aa 6a ea 1a 9a 5a da 3a ba 7a fa),    # 5
    qw(06 86 46 c6 26 a6 66 e6 16 96 56 d6 36 b6 76 f6),    # 6
    qw(0e 8e 4e ce 2e ae 6e ee 1e 9e 5e de 3e be 7e fe),    # 7
    qw(01 81 41 c1 21 a1 61 e1 11 91 51 d1 31 b1 71 f1),    # 8
    qw(09 89 49 c9 29 a9 69 e9 19 99 59 d9 39 b9 79 f9),    # 9
    qw(05 85 45 c5 25 a5 65 e5 15 95 55 d5 35 b5 75 f5),    # a
    qw(0d 8d 4d cd 2d ad 6d ed 1d 9d 5d dd 3d bd 7d fd),    # b
    qw(03 83 43 c3 23 a3 63 e3 13 93 53 d3 33 b3 73 f3),    # c
    qw(0b 8b 4b cb 2b ab 6b eb 1b 9b 5b db 3b bb 7b fb),    # d
    qw(07 87 47 c7 27 a7 67 e7 17 97 57 d7 37 b7 77 f7),    # e
    qw(0f 8f 4f cf 2f af 6f ef 1f 9f 5f df 3f bf 7f ff),    # f
);

use base qw( Exporter );
use vars qw( %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_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_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 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_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_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( q{-}, map { (ETHER2TOKEN)[$_] } @{ $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_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__