File Coverage

blib/lib/Device/OUI.pm

Criterion	Covered	Total	%
statement	208	233	89.2
branch	82	106	77.3
condition	16	20	80.0
subroutine	33	33	100.0
pod	24	24	100.0
total	363	416	87.2

package Device::OUI;
use strict; use warnings;
our $VERSION = '1.04';
use IO::File ();
use Carp qw( croak carp );
use AnyDBM_File;
use overload (
    '<=>' => 'overload_cmp',
    'cmp' => 'overload_cmp',
    '""'  => 'normalized',
    fallback => 1,
);
use base qw( Class::Accessor::Grouped );
use Sub::Exporter -setup => {
    exports => [qw( normalize_oui oui_cmp parse_oui_entry oui_to_integers )],
};

__PACKAGE__->mk_group_accessors( inherited => qw(
    cache_db cache_file
    file_url search_url
) );
my $cache = $^O eq 'MSWin32' ? 'C:\device_oui' : '/var/cache/device_oui';
__PACKAGE__->cache_db( $cache );
__PACKAGE__->cache_file( $cache . '.txt' );
__PACKAGE__->search_url( 'http://standards.ieee.org/cgi-bin/ouisearch?%s' );
__PACKAGE__->file_url( 'http://standards.ieee.org/regauth/oui/oui.txt' );

sub cache_handle {
    my $self = shift;

    if ( @_ ) { $self->set_inherited( 'cache_handle', @_ ) }
    my $handle = $self->get_inherited( 'cache_handle' );
    if ( $handle ) { return $handle }
    $handle = {};
    if ( my $db = $self->cache_db ) {
        my $opts = Fcntl::O_RDWR | Fcntl::O_CREAT;
        my %cache;
        if ( tie( %cache, 'AnyDBM_File', $db, $opts, 0666 ) ) { ## no critic
            $handle = \%cache;
        }
    }
    $self->set_inherited( 'cache_handle', $handle );
    return $handle;
}

sub cache {
    my $self = shift;
    my $oui = ( @_ && not ref $_[0] ) ? shift : $self->norm;

    my $handle = $self->cache_handle;

    if ( @_ ) {
        my %hash = %{ shift() };
        for my $x ( keys %hash ) {
            if ( not defined $hash{ $x } ) { $hash{ $x } = '' }
        }
        return $handle->{ $oui } = join( "\0", %hash );
    } elsif ( my $x = $handle->{ $oui } ) {
        return { split( "\0", $x ) };
    }
    return;
}

sub new {
    my $self = bless( {}, shift );
    $self->oui( shift ) if @_;
    return $self;
}

sub oui {
    my $self = shift;

    if ( @_ ) {
        my $oui = shift;
        if ( my $norm = normalize_oui( $oui ) ) {
            $self->{ 'oui' } = $oui;
            $self->{ 'oui_norm' } = $norm;
            delete $self->{ 'lookup' };
        } else {
            croak "Invalid OUI format: $oui";
        }
    }

    if ( not $self->{ 'oui' } ) { croak "Object does not have an OUI" }

    return $self->{ 'oui' };
}

sub oui_to_integers {
    my $oui = shift || return;

    if ( ref $oui ) { return map { hex } split( '-', $oui->norm ) }

    # 00-06-2A or 0:6:2a, etc. any non-hex delimiter will do
    {
        my @parts = grep { length } split( /[^a-f0-9]+/i, $oui );
        if ( @parts == 3 ) { return map { hex } @parts }
    }

    # 00062a, requires exactly 6 hex characters
    {
        my @parts = ( $oui =~ /([a-f0-9])/ig );
        if ( @parts == 6 ) {
            return(
                hex( $parts[0].$parts[1] ),
                hex( $parts[2].$parts[3] ),
                hex( $parts[4].$parts[5] ),
            );
        }
    }
    return ();
}

sub normalize_oui {
    my $oui = shift;
    my @int = oui_to_integers( $oui ) or return;
    return sprintf( '%02X-%02X-%02X', @int );
}

sub normalized { return shift->{ 'oui_norm' } }
*norm = \&normalized;

sub organization { return shift->lookup->{ 'organization' } }
sub company_id { return shift->lookup->{ 'company_id' } }
sub address { return shift->lookup->{ 'address' } }

sub is_private {
    my $self = shift;

    return $self->organization eq 'PRIVATE' ? 1 : 0;
}

sub lookup {
    my $self = shift;

    my $x;
    if ( $x = $self->{ 'lookup' } ) { return $x }

    if ( $x = $self->cache ) { return $self->{ 'lookup' } = $x }
    if ( $x = $self->update_from_file ) { return $self->{ 'lookup' } = $x }
    if ( $x = $self->update_from_web ) { return $self->{ 'lookup' } = $x }
    if ( $self->mirror_file ) {
        if ( $x = $self->update_from_file ) {
            return $self->{ 'lookup' } = $x;
        }
    }

    return $self->{ 'lookup' } = {};
}

sub update_from_file {
    my $self = shift;
    my $oui = $self->norm;

    my $cf = $self->cache_file;
    if ( ! $cf ) { return }
    my $fh = IO::File->new( $cf, 'r' );
    if ( ! $fh ) { return }

    local $/ = "";

    while ( my $entry = $fh->getline ) {
        if ( substr( $entry, 0, 8 ) eq $oui ) {
            my $data = $self->parse_oui_entry( $entry );
            $self->cache( $data );
            return $data;
        }
    }
    return;
}

{
    my $HAVE_LWP_SIMPLE;
    sub have_lwp_simple {
        my $self = shift;
        if ( defined $HAVE_LWP_SIMPLE ) { return $HAVE_LWP_SIMPLE }
        eval "require LWP::Simple"; ## no critic
        if ( $@ ) {
            carp "Unable to load LWP::Simple, network access not available\n";
            $HAVE_LWP_SIMPLE = 0;
        } else {
            $HAVE_LWP_SIMPLE = 1;
        }
    }
}

sub mirror_file {
    my $self = shift;
    my $url  = shift || $self->file_url;
    if ( ! $url ) { return }
    my $file = shift || $self->cache_file;
    if ( ! $file ) { return }
    if ( ! $self->have_lwp_simple ) { return }

    my $res = LWP::Simple::mirror( $url, $file );
    if ( $res == LWP::Simple::RC_NOT_MODIFIED() ) { return 0 }
    if ( ! LWP::Simple::is_success( $res ) ) {
        carp "Failed to mirror $url to $file ($res)";
        return;
    }
    return 1;
}

sub get_url {
    my $self = shift;
    my $url = shift;
    if ( ! $url ) { return }

    return LWP::Simple::get( $url );
}

sub load_cache_from_web {
    my $self = shift;
    my $url  = shift || $self->file_url;
    if ( ! $url ) { return }
    my $file = shift || $self->cache_file;
    if ( ! $file ) { return }

    if ( $self->mirror_file( $url, $file ) ) {
        return $self->load_cache_from_file( $file );
    }
    return;
}

sub load_cache_from_file {
    my $self = shift;
    my $file = shift;
    if ( ! $file ) { $file = $self->cache_file }
    if ( ! $file ) { return }

    my $fh = IO::File->new( $file );
    local $/ = "";
    $fh->getline; # dump the header
    my $counter = 0;
    while ( my $entry = $fh->getline ) {
        my $data = $self->parse_oui_entry( $entry );
        $self->cache( $data->{ 'oui' } => $data );
        $counter++;
    }
    return $counter;
}

sub search_url_for {
    my $self = shift;
    my $oui = normalize_oui( shift );
    if ( ! $oui ) { $oui = $self->norm }

    my $url_format = $self->search_url;
    if ( ! $url_format ) { return }

    if ( $url_format =~ /%s/ ) {
        return sprintf( $url_format, $oui );
    } else {
        return $url_format.$oui;
    }
}

sub update_from_web {
    my $self = shift;

    if ( not ref $self ) { return }
    if ( not $self->have_lwp_simple ) { return }

    my $url = $self->search_url_for;
    if ( ! $url ) { return }

    if ( my $page = $self->get_url( $url ) ) {
        if ( $page =~ /listing contains no match/ ) { return }
        my @entries = ( $page =~ m{(.*?)}gs );
        if ( @entries > 1 ) { croak "Too many entries returned from $url\n" }
        my $data = $self->parse_oui_entry( shift( @entries ) );
        $self->cache( $data );
        return $data;
    }
    return;
}

sub parse_oui_entry {
    local $_ = pop( @_ ); # pop in case we get called as a class method
use Carp qw( confess );
    if ( ! $_ ) { confess "eh?" }
    s{}{}g;
    s/\r//g;

    s/\s*\(hex\)\s*/\n/gm;
    s/\s*\(base 16\).*$//gm;
    s/^\s*|\s*$//gsm;

    my %data = ();
    @data{ qw( oui organization company_id address ) } = split( "\n", $_, 4 );
    delete $data{ 'address' } unless $data{ 'address' };
    return \%data;
}

sub overload_cmp { return oui_cmp( pop( @_ ) ? reverse @_ : @_ ) }
sub oui_cmp {
    my @l = oui_to_integers( shift );
    my @r = oui_to_integers( shift );

    return ( $l[0] <=> $r[0] || $l[1] <=> $r[1] || $l[2] <=> $r[2] );
}

sub dump_cache {
    my $self = shift;

    my @lines = (
        "\n",
        "OUI\t\t\t\tOrganization\n",
        "company_id\t\t\tOrganization\n",
        "\t\t\t\tAddress\n",
        "\n", "\n",
    );

    my $db = $self->cache_handle;

    foreach my $oui ( sort { $a cmp $b } keys %{ $db } ) {
        my $d = { split( "\0", $db->{ $oui } ) };
        my $org = $d->{ 'organization' };

        push( @lines,
            sprintf( "%-10s (hex)\t\t%s\n", $d->{ 'oui' }, $org ),
            sprintf(
                "%-10s (base 16)\t\t%s\n",
                $d->{ 'company_id' },
                $org eq 'PRIVATE' ? '' : $org,
            ),
        );
        if ( my $a = $d->{ 'address' } ) {
            for my $x ( split( "\n", $d->{ 'address' } ) ) {
                push( @lines, "\t\t\t\t$x\n" );
            }
            push( @lines, "\n" );
        } else {
            push( @lines, "\t\t\t\t\n" );
        }
    }

    return join( "", @lines );
}

1;

__END__