File Coverage

blib/lib/Sys/HostIP.pm

Criterion	Covered	Total	%
statement	103	111	92.7
branch	37	50	74.0
condition	15	18	83.3
subroutine	17	18	94.4
pod	5	6	83.3
total	177	203	87.1

package Sys::HostIP;
$Sys::HostIP::VERSION = '2.120';
# ABSTRACT: Try extra hard to get IP address related info

use strict;
use warnings;

use Carp;
use Exporter;
use File::Basename 'dirname';
use parent 'Exporter';

our @EXPORT_OK = qw( ip ips interfaces ifconfig );

our $IS_WIN = $^O =~ qr/(MSWin32|cygwin)/xms; ## no critic qw(Variables::ProhibitPunctuationVars)

sub new { ## no critic qw(Subroutines::RequireArgUnpacking)
    my $class = shift
        or croak 'Cannot create new method in a functional way';

    my %opts = @_;
    my $self = bless {%opts}, $class;

    # only get ifconfig binary if it's not a windows
    $self->{'ifconfig'} ||= $IS_WIN ? '' : $self->_get_ifconfig_binary;
    $self->{'if_info'}  ||= $self->_get_interface_info;

    return $self;
}

sub ifconfig {
    my $self = shift;
    my $path = shift;

    if ( !ref $self ) {
        return $self->_get_ifconfig_binary;
    }

    # set path
    $path and $self->{'ifconfig'} = $path;

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

sub ip {
    my $self = shift || 'Sys::HostIP';
    my $if_info;

    if ( !ref $self ) {
        $if_info = $self->_get_interface_info;
    } else {
        $if_info = $self->if_info;
    }

    if ($IS_WIN) {
        my @if_keys = sort keys %{$if_info};
        return scalar @if_keys != 0 ? ( $if_info->{ $if_keys[0] } ) : '';
    } else {
        my $lo_found;

        foreach my $key ( sort keys %{$if_info} ) {

            # we don't want the loopback
            if ( $if_info->{$key} eq '127.0.0.1' ) {
                $lo_found++;
                next;
            }

            # now we return the first one that comes up
            return ( $if_info->{$key} );
        }

        # we get here if loopback is the only active device
        $lo_found and return '127.0.0.1';

        return '';
    }
}

sub ips {
    my $self = shift || 'Sys::HostIP';

    if ( !ref $self ) {
        return [ values %{ $self->_get_interface_info } ];
    }

    return [ values %{ $self->if_info } ];
}

sub interfaces {
    my $self = shift || 'Sys::HostIP';

    if ( !ref $self ) {
        return $self->_get_interface_info;
    }

    return $self->if_info;
}

sub if_info {
    my $self = shift;

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

sub _get_ifconfig_binary {
    my $self     = shift;
    my $ifconfig = '/sbin/ifconfig -a';

    ## no critic qw(Variables::ProhibitPunctuationVars)
    if ( $^O =~ /(?: linux|openbsd|freebsd|netbsd|solaris|darwin )/xmsi ) {
        $ifconfig = -f '/sbin/ifconfig' ? '/sbin/ifconfig -a' : '/sbin/ip address';
    } elsif ( $^O eq 'aix' ) {
        $ifconfig = '/usr/sbin/ifconfig -a';
    } elsif ( $^O eq 'irix' ) {
        $ifconfig = '/usr/etc/ifconfig';
    } elsif ( $^O eq 'dec_osf' ) {
        $ifconfig = '/sbin/ifconfig';
    } else {
        carp "Unknown system ($^O), guessing ifconfig is in /sbin/ifconfig "
            . "(email xsawyerx\@cpan.org with the location of your ifconfig)\n";
    }

    return $ifconfig;
}

sub _get_interface_info {
    my $self = shift;

    my $interface_info = $IS_WIN
        ? $self->_get_win32_interface_info()
        : $self->_get_unix_interface_info();

    my $warning_msg = "Unable to detect interface information!\n"
        . "Please open an issue on https://github.com/xsawyerx/sys-hostip/issues with your 'ipconfig' or 'ifconfig' output";
    warn $warning_msg if values %$interface_info == 0;

    return $interface_info;
}

sub _clean_ifconfig_env {
    my $self = shift;

    # this is an attempt to fix tainting problems

    # removing $BASH_ENV, which exists if /bin/sh is your bash
    delete $ENV{'BASH_ENV'};

    # now we set the local $ENV{'PATH'} to be only the path to ifconfig
    # We have localized %ENV in the call to this, so we disable critic warning
    ## no critic qw(Variables::RequireLocalizedPunctuationVars)
    my $ifconfig = $self->ifconfig;
    $ENV{'PATH'} = dirname $ifconfig;

    return $ifconfig;
}

sub _get_unix_interface_info {
    my $self = shift;

    # localize the environment
    local %ENV;

    # make sure nothing else has touched $/
    local $/ = "\n";

    my ( $ip, $interface, %if_info );

    # clean environment for taint mode
    my $ifconfig_bin = $self->_clean_ifconfig_env();
    my @ifconfig     = `$ifconfig_bin`;

    foreach my $line (@ifconfig) {

        # TODO: refactor this into tests
        # output from 'ifconfig -a' looks something like this on every *nix i
        # could get my hand on except linux (this one's actually from OpenBSD):
        #
        # gershiwin:~# /sbin/ifconfig -a
        # lo0: flags=8009
        #         inet 127.0.0.1 netmask 0xff000000
        # lo1: flags=8008
        # xl0: flags=8843
        #         media: Ethernet autoselect (100baseTX full-duplex)
        #         status: active
        #         inet 10.0.0.2 netmask 0xfffffff0 broadcast 10.0.0.255
        # sl0: flags=c010
        # sl1: flags=c010
        #
        # in linux it's a little bit different:
        #
        # [jschatz@nooky Sys-IP]$ /sbin/ifconfig
        #  eth0      Link encap:Ethernet  HWaddr 00:C0:4F:60:6F:C2
        #           inet addr:10.0.3.82  Bcast:10.0.255.255  Mask:255.255.0.0
        #           UP BROADCAST RUNNING MULTICAST  MTU:1500  Metric:1
        #           Interrupt:19 Base address:0xec00
        #  lo        Link encap:Local Loopback
        #           inet addr:127.0.0.1  Mask:255.0.0.0
        #           UP LOOPBACK RUNNING  MTU:3924  Metric:1
        #
        # In linux, using /sbin/ip it looks like:
        # [goldenboy:~] adamb $ ip address
        # 1: lo:    mtu 65536 qdisc noqueue state UNKNOWN group default
        #     link/loopback 00:00:00:00:00:00 brd 00:00:00:00:00:00
        #     inet 127.0.0.1/8 scope host lo
        #        valid_lft forever preferred_lft forever
        #     inet6 ::1/128 scope host
        #        valid_lft forever preferred_lft forever
        # 2: eth0:  mtu 1500 qdisc pfifo_fast state DOWN group default qlen 1000
        #     link/ether 9c:b6:54:a5:64:60 brd ff:ff:ff:ff:ff:ff
        #
        # so the regexen involved here have to deal with the following: 1)
        # there's no ':' after an interface's name in linux 2) in linux, it's
        # "inet addr:127.0.0.1" instead of "inet 127.0.0.1" hence the somewhat
        # hairy regexen /(^\w+(?:\d)?(?:\:\d)?)/ (which also handles aliased ip
        # addresses , ie eth0:1) and /inet(?:addr\:)?(\d+\.\d+\.\d+\.\d+)/
        #
        # so we parse through the list returned. if the line starts with some
        # letters followed (possibly) by an number and a colon, then we've got an
        # interface. if the line starts with a space, then it's the info from the
        # interface that we just found, and we stick the contents into %if_info
        if ( ( $line =~ /^\s+/x ) && ($interface) ) {
            $if_info{$interface} .= $line;
        }

        # FIXME: refactor this regex
        elsif ( ($interface) = ( $line =~ /^(?:\d+\:\s){0,1}(\w+(?:\d)?(?:\.\d+)?(?:\:\d+)?)/x ))
        {
            $line =~ s/\w+\d(\:)?\s+//x;
            $if_info{$interface} = $line;
        }
    }

    foreach my $key ( keys %if_info ) {

        # now we want to get rid of all the other crap in the ifconfig
        # output. we just want the ip address. perhaps a future version can
        # return even more useful results (netmask, etc).....
        if ( my ($ip)
            = ( $if_info{$key} =~ /inet\s(?:addr\:)?(\d+(?:\.\d+){3})/x ) )
        {
            $if_info{$key} = $ip;
        } else {

            # ok, no ip address here, which means this interface isn't
            # active. some os's (openbsd for instance) spit out ifconfig info for
            # inactive devices. this is pretty much worthless for us, so we
            # delete it from the hash
            delete $if_info{$key};
        }
    }

    # now we do some cleanup by deleting keys that have no associated info
    # (some os's like openbsd list inactive interfaces when 'ifconfig -a' is
    # used, and we don't care about those
    return \%if_info;
}

sub _run_ipconfig {
    return `ipconfig`;
}

sub _get_win32_interface_info {
    my $self    = shift;
    my %regexes = (
        address => qr/
            \s+
            IP(?:v4)? .*? :
            \s+
            (\d+ (?: \. \d+ ){3} )
        /x,

        adapter => qr/
            ^
            (?:
                Ethernet(?:\s?|-)\w+
                |
                .*?\s+Ethernet
            )
            \s+
            (.*) :
        /x,
    );

    my @ipconfig = $self->_run_ipconfig();
    my ( $interface, %if_info );

    foreach my $line (@ipconfig) {
        chomp($line);

        if ( $line =~ /Windows/xms ) {

            # ignore the header
            next;
        } elsif ( $line =~ /^\s$/xms ) {
            next;
        } elsif ( ( $line =~ $regexes{'address'} ) and defined $interface ) {
            $if_info{$interface} = $1;
            $interface = undef;
        } elsif ( $line =~ $regexes{'adapter'} ) {
            $interface = $1;
            chomp $interface;
            $interface =~ s/\s+$//gxms; # remove trailing whitespace, if any
        }
    }

    return \%if_info;
}

1;

__END__