File Coverage

blib/lib/Sys/HostIP.pm

Criterion	Covered	Total	%
statement	87	111	78.3
branch	22	46	47.8
condition	10	21	47.6
subroutine	17	18	94.4
pod	5	6	83.3
total	141	202	69.8

use strict;
use warnings;
package Sys::HostIP;
# ABSTRACT: Try extra hard to get IP address related info
$Sys::HostIP::VERSION = '2.000';
use Carp;
use Exporter;
use File::Basename 'dirname';
use vars qw( @ISA @EXPORT_OK );

@ISA       = qw(Exporter);
@EXPORT_OK = qw( ip ips interfaces ifconfig );

my $is_win = $^O =~ qr/(MSWin32|cygwin)/;

sub new {
    my $class = shift || 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) {
        foreach my $key ( sort keys %{$if_info} ) {
            # should this be the default?
            if ( $key =~ /Local Area Connection/ ) {
                return ( $if_info->{$key} );
            }
        }
    } 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;

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

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

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

    if ( $^O =~ /(?: linux|openbsd|freebsd|netbsd|solaris|darwin )/xi ) {
        $ifconfig =  '/sbin/ifconfig -a';
    } 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 $if_info = $is_win                            ?
                  $self->_get_win32_interface_info() :
                  $self->_get_unix_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
    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
        #
        # 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+/) && ($interface) ) {
            $if_info{$interface} .= $line;
        }
        # FIXME: refactor this regex
        elsif (($interface) = ($line =~/(^\w+(?:\d)?(?:\.\d+)?(?:\:\d+)?)/)) {
            $line =~s/\w+\d(\:)?\s+//;
            $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 (?:addr\:)?(\d+(?:\.\d+){3})/)) {
            $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+|\w+\s+Ethernet)
            \s+
            (.*) :
        /x,
    );

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

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

        if ( $line =~ /Windows/ ) {
            # ignore the header
            next;
        } elsif ( $line =~/^\s$/ ) {
            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+$//g;  # remove trailing whitespace, if any
        }
    }

    return \%if_info;
}

1;

__END__