File Coverage

blib/lib/Net/Address/Ethernet.pm

Criterion	Covered	Total	%
statement	108	166	65.0
branch	30	62	48.3
condition	6	26	23.0
subroutine	18	19	94.7
pod	4	4	100.0
total	166	277	59.9

package Net::Address::Ethernet;

use warnings;
use strict;

=head1 NAME

Net::Address::Ethernet - find hardware ethernet address

=head1 SYNOPSIS

  use Net::Address::Ethernet qw( get_address );
  my $sAddress = get_address;

=head1 FUNCTIONS

The following functions will be exported to your namespace if you request :all like so:

  use Net::Address::Ethernet qw( :all );

=over

=cut

use Carp;
use Data::Dumper; # for debugging only
use Exporter;
use Net::Domain;
use Net::Ifconfig::Wrapper qw( Ifconfig );
use Regexp::Common;
use Sys::Hostname;

use constant DEBUG_MATCH => 0;

use vars qw( $DEBUG $VERSION @EXPORT_OK %EXPORT_TAGS );
use base 'Exporter';

$VERSION = 1.128;

$DEBUG = 0 || $ENV{N_A_E_DEBUG};

%EXPORT_TAGS = ( 'all' => [ qw( get_address get_addresses canonical is_address ), ], );
@EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

my @ahInfo;

=item get_address

Returns the 6-byte ethernet address in canonical form.
For example, '1A:2B:3C:4D:5E:6F'.

When called in array context, returns a 6-element list representing
the 6 bytes of the address in decimal.  For example,
(26,43,60,77,94,111).

If any non-zero argument is given,
debugging information will be printed to STDERR.

=cut

sub get_address
  {
  # warn " TTT get_address()";
  if (0)
    {
    # If you know the name of the adapter, you can use this code to
    # get its IP address:
    use Socket qw/PF_INET SOCK_DGRAM inet_ntoa sockaddr_in/;
    if (! socket(SOCKET, PF_INET, SOCK_DGRAM, getprotobyname('ip')))
      {
      warn " WWW socket() failed\n";
      goto IFCONFIG_VERSION;
      } # if
    # use ioctl() interface with SIOCGIFADDR.
    my $ifreq = pack('a32', 'enp1s0');
    if (! ioctl(SOCKET, 0x8915, $ifreq))
      {
      warn " WWW ioctl failed\n";
      goto IFCONFIG_VERSION;
      } # if
    # Format the IP address from the output of ioctl().
    my $s = inet_ntoa((sockaddr_in((unpack('a16 a16', $ifreq))[1]))[1]);
    if (! $s)
      {
      warn " WWW inet_ntoa failed\n";
      goto IFCONFIG_VERSION;
      } # if
    warn Dumper($s); exit 88; # for debugging
    } # if 0
 IFCONFIG_VERSION:
  my @a = get_addresses(@_);
  _debug(" DDD in get_address, a is ", Dumper(\@a));
  # Even if none are active, we'll return the first one:
  my $sAddr = $a[0]->{sEthernet};
  # Look through the list, returning the first active one that has a
  # non-loopback IP address assigned to it:
 TRY_ADDR:
  foreach my $rh (@a)
    {
    my $sName = $rh->{sAdapter};
    _debug(" DDD inspecting interface $sName...\n");
    if (! $rh->{iActive})
      {
      _debug(" DDD   but it is not active.\n");
      next TRY_ADDR;
      } # if
    _debug(" DDD   it is active...\n");
    if (! exists $rh->{sIP})
      {
      _debug(" DDD   but it has no IP address.\n");
      next TRY_ADDR;
      } # if
    if (! defined $rh->{sIP})
      {
      _debug(" DDD   but its IP address is undefined.\n");
      next TRY_ADDR;
      } # if
    if ($rh->{sIP} eq '')
      {
      _debug(" DDD   but its IP address is empty.\n");
      next TRY_ADDR;
      } # if
    if ($rh->{sIP} eq '127.0.0.1')
      {
      _debug(" DDD   but it's the loopback.\n");
      next TRY_ADDR;
      } # if
    if (! exists $rh->{sEthernet})
      {
      _debug(" DDD   but it has no ethernet address.\n");
      next TRY_ADDR;
      } # if
    if (! defined $rh->{sEthernet})
      {
      _debug(" DDD   but its ethernet address is undefined.\n");
      next TRY_ADDR;
      } # if
    if ($rh->{sEthernet} eq q{})
      {
      _debug(" DDD   but its ethernet address is empty.\n");
      next TRY_ADDR;
      } # if
    $sAddr = $rh->{sEthernet};
    _debug(" DDD   and its ethernet address is $sAddr.\n");
    last TRY_ADDR;
    } # foreach TRY_ADDR
  return wantarray ? map { hex } split(/[-:]/, $sAddr) : $sAddr;
  } # get_address


=item get_addresses

Returns an array of hashrefs.
Each hashref describes one Ethernet adapter found in the current hardware configuration,
with the following entries filled in to the best of our ability to determine:

=over

=item sEthernet -- The MAC address in canonical form.

=item rasIP -- A reference to an array of all the IP addresses on this adapter.

=item sIP -- The "first" IP address on this adapter.

=item sAdapter -- The name of this adapter.

=item iActive -- Whether this adapter is active.

=back

For example:

  {
   'sAdapter' => 'Ethernet adapter Local Area Connection',
   'sEthernet' => '12:34:56:78:9A:BC',
   'rasIP' => ['111.222.33.44',],
   'sIP' => '111.222.33.44',
   'iActive' => 1,
  },

If any non-zero argument is given,
debugging information will be printed to STDERR.

=cut

sub get_addresses
  {
  # warn " TTT get_addresses()";
  $DEBUG ||= shift;
  # Short-circuit if this function has already been called:
  if (! $DEBUG && @ahInfo)
    {
    goto ALL_DONE;
    } # if
  my $sAddr = undef;
  my $rh = Ifconfig('list', '', '', '');
  if ((! defined $rh) || (! scalar keys %$rh))
    {
    # warn " WWW Ifconfig failed: $@";
    if ($@ =~ m/not found/)
      {
      # At this point we might try another method, such as calling /sbin/ip
      my $sCmdIp = '/sbin/ip';
      if (! -f $sCmdIp)
        {
        warn " DDD $sCmdIp does not exist";
        }
      else
        {
        $sCmdIp .= q/ addr show/;
        my @asOutput = qx/$sCmdIp/;
        # print STDERR " DDD asOutput ==@asOutput";
        my $sInterface = q//;
        my %hash;
        foreach my $sLine (@asOutput)
          {
          # print STDERR " DDD sLine ==$sLine";
          if ($sLine =~ m/\d:\s(.+?):.+,UP/)
            {
            # Found an interface that is in UP state
            push @ahInfo, {%hash} if %hash;
            $sInterface = $1;
            # Start a new adapter's info:
            %hash = ();
            $hash{sAdapter} = $sInterface;
            $hash{iActive} = 1;
            _debug(" DDD   hash is ", Dumper(\%hash));
            } # if
          if ($sLine =~ m/ether\s+(([0-9a-f]{2}:){5}[0-9a-f]{2})/)
            {
            $hash{sEthernet} = canonical($1);
            _debug(" DDD   hash is ", Dumper(\%hash));
            } # if
          if ($sLine =~ m/inet\s+((\d+\.){3}\d+)/)
            {
            $hash{sAdapter} = $sInterface;
            $hash{sIP} = $1;
            $hash{rasIP} = [$1];
            _debug(" DDD   hash is ", Dumper(\%hash));
            } # if
          } # foreach
        push @ahInfo, {%hash} if %hash;
        } # if
      } # if
    # No sense trying to parse non-existent output:
    goto ALL_DONE;
    } # if
  _debug(" DDD raw output from Ifconfig is ", Dumper($rh));
  # Convert their hashref to our array format:
  foreach my $key (keys %$rh)
    {
    my %hash;
    _debug(" DDD working on key $key...\n");
    my $sAdapter = $key;
    if ($key =~ m!\A\{.+}\z!)
      {
      $sAdapter = $rh->{$key}->{descr};
      } # if
    $hash{sAdapter} = $sAdapter;
    my @asIP = keys %{$rh->{$key}->{inet}};
    # Thanks to Sergey Kotenko for the array idea:
    $hash{rasIP} = \@asIP;
    $hash{sIP} = $asIP[0];
    my $sEther = $rh->{$key}->{ether} || '';
    if ($sEther eq '')
      {
      $sEther = _find_mac($sAdapter, $hash{sIP});
      } # if
    $hash{sEthernet} = canonical($sEther);
    $hash{iActive} = 0;
    if (defined $rh->{$key}->{status} && ($rh->{$key}->{status} =~ m!\A(1|UP)\z!i))
      {
      $hash{iActive} = 1;
      } # if
    push @ahInfo, \%hash;
    } # foreach
 ALL_DONE:
  return @ahInfo;
  } # get_addresses


# Attempt other ways of finding the MAC Address:
sub _find_mac
  {
  my $sAdapter = shift || return;
  my $sIP = shift || '';
  # No hope on some OSes:
  return if ($^O eq 'MSWIn32');
  my @asARP = qw( /usr/sbin/arp /sbin/arp /bin/arp /usr/bin/arp );
  my $sHostname = hostname || Net::Domain::hostname || '';
  my $sHostfqdn = Net::Domain::hostfqdn || '';
  my @asHost = ($sHostname, $sHostfqdn, '');
 ARP:
  foreach my $sARP (@asARP)
    {
    next ARP if ! -x $sARP;
 HOSTNAME:
    foreach my $sHost (@asHost)
      {
      $sHost ||= q{};
      next HOSTNAME if ($sHost eq q{});
      my $sCmd = qq{$sARP $sHost};
      # print STDERR " DDD trying ==$sCmd==\n";
      my @as = qx{$sCmd};
 LINE_OF_CMD:
      while (@as)
        {
        my $sLine = shift @as;
        DEBUG_MATCH && print STDERR " DDD output line of cmd ==$sLine==\n";
        if ($sLine =~ m!\(($RE{net}{IPv4})\)\s+AT\s+($RE{net}{MAC})\b!i)
          {
          # Looks like arp on Solaris.
          my ($sIPFound, $sEtherFound) = ($1, $2);
          # print STDERR " DDD     found IP =$sIPFound=, found ether =$sEtherFound=\n";
          return $sEtherFound if ($sIPFound eq $sIP);
          # print STDERR " DDD     does NOT match the one I wanted =$sIP=\n";
          } # if
        if ($sLine =~ m!($RE{net}{IPv4})\s+ETHER\s+($RE{net}{MAC})\b!i)
          {
          # Looks like arp on Solaris.
          return $2 if ($1 eq $sIP);
          } # if
        } # while LINE_OF_CMD
      } # foreach HOSTNAME
    } # foreach ARP
  } # _find_mac

=item is_address

Returns a true value if its argument looks like an ethernet address.

=cut

sub is_address
  {
  my $s = uc(shift || '');
  # Convert all non-hex digits to colon:
  $s =~ s![^0-9A-F]+!:!g;
  return ($s =~ m!\A$RE{net}{MAC}\Z!i);
  } # is_address


=item canonical

Given a 6-byte ethernet address, converts it to canonical form.
Canonical form is 2-digit uppercase hexadecimal numbers with colon
between the bytes.  The address to be converted can have any kind of
punctuation between the bytes, the bytes can be 1-digit, and the bytes
can be lowercase; but the bytes must already be hex.

=cut

sub canonical
  {
  my $s = shift;
  return '' if ! is_address($s);
  # Convert all non-hex digits to colon:
  $s =~ s![^0-9a-fA-F]+!:!g;
  my @as = split(':', $s);
  # Cobble together 2-digit hex bytes:
  $s = '';
  map { $s .= length() < 2 ? "0$_" : $_; $s .= ':' } @as;
  chop $s;
  return uc $s;
  } # canonical

sub _debug
  {
  return if ! $DEBUG;
  print STDERR @_;
  } # _debug

=back

=head1 NOTES

=head1 SEE ALSO

arp, ifconfig, ipconfig

=head1 BUGS

Please tell the author if you find any!  And please show me the output
of `arp `
or `ifconfig`
or `ifconfig -a`
from your system.

=head1 AUTHOR

Martin 'Kingpin' Thurn, C, L.

=head1 LICENSE

This software is released under the same license as Perl itself.

=cut

1;

__END__