File Coverage

blib/lib/Net/DHCP/Watch.pm

Criterion	Covered	Total	%
statement	82	96	85.4
branch	16	36	44.4
condition	2	5	40.0
subroutine	14	15	93.3
pod	4	6	66.6
total	118	158	74.6

#
#$Id: Watch.pm,v 2.3 2003/10/28 11:09:59 edelrio Exp $
#
# Net::DHCP::Watch
#
package Net::DHCP::Watch;

use strict;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);

use Carp;
use Config;
use Socket;
use Net::hostent;
use IO::Socket;

require Exporter;

@ISA       = qw(Exporter);
@EXPORT    = qw();
@EXPORT_OK = qw();

$VERSION = do { my @r=(q$Revision: 2.3 $=~/\d+/g); sprintf "%d."."%02d"x$#r,@r };

#
# new
#
sub new {
    my $proto  = shift;
    my $params = shift;
    my $class  = ref($proto) || $proto;
    my $self   = {};
    bless($self, $class);
    $self->init($params);
    return $self;
}
#
# init: initalize parameters.
#
sub init {
    my $self   = shift;
    my $params = shift;
    my $h;

    # test if server hostname given is known (name or IP)
    $self->{Server} = $params->{server};
    unless ( $h = gethost($self->{Server}) ) {
	carp "Can not resolve: ",$self->{Server};
    }

    # test if client hostname given is known (name or IP)
    # and keep only the first IP address.
    $self->{Client} = $params->{client};
    unless ( $h = gethost($self->{Client}) ) {
	carp "Can not resolve: ",$self->{Client};
    }
    $self->{Client} = $h->addr_list->[0];


    # test if ethernet address is either an array of six bytes or
    # a string of hex bytes separated by ':'
    $self->{Ether}  = $params->{ether};

    if ( $self->{Ether} =~ m/^([0-9a-f]{1,2}:)+[0-9a-f]{1,2}$/i ) {
	my @eth = map( hex, split(':', $self->{Ether}) );
	$self->{Ether} = \@eth;
    }
    elsif ( scalar($self->{Ether}) != 6 ) {
	croak "Not a good ethernet addres: ",$params->{ether};
    }

    # can we use alarm() ?
    if ( $Config{d_alarm} eq 'define' ) {
	$self->{_Alarm} = 1;
    }
    else {
	carp "No alarm() function, network operation may hang";
	$self->{_Alarm} = 0;
    }

    # set the timeout (alarm)
    $self->{TimeOut} = $params->{timeout} || 10;

    # initialize status result to zero
    $self->{Last} = {
	Ok   => 0,
	Bad  => 0,
	Time => '0000-00-00 00:00:00 GMT'
    };
    return;
}

#
# watch: opens the udp socket to the server
#
sub watch {
    my $self = shift;
    if ( $self->{Watcher} ) {
	carp "Already watching.";
    }
    else {
	$self->{Watcher} = new IO::Socket::INET(
						PeerAddr  => $self->{Server},
						PeerPort  => 'bootps(67)',
						LocalAddr => inet_ntoa($self->{Client}),
						LocalPort => 'bootpc(68)',
						Proto     => 'udp',
						Timeout   => $self->{TimeOut}
						)
	    or carp "Can not watch: $!";
    }
    return $self->{Watcher};
}

#
# status: returns the present status
#
sub status {
    my $self = shift;
    # now the watch/unwatch cycle is carried by status.
    $self->watch unless( $self->{Watcher} );
    $self->dhcp_query or return;
    $self->unwatch;
    return $self->{Last};
}

#
# dhcp_query: sends an udp packet containig a DHCP message
# of type DHCPDISCOVER and listens to the reply. The random transaction id
# must match.
#
sub dhcp_query {
    my $self = shift;
    my $reply; # holdspace for udp reply
    #
    # Test if socket is ok
    #
    unless ( $self->{Watcher} ) {
	carp "Not watching yet!";
	return;
    };
    #
    # Transaction ID
    #
    my $xid = int(rand(2**32-1));
    #
    # DHCP Message: Fixed-Format + Options
    # (see Droms & Lemon, 1999, Apendixes C and D).
    #
    my @fields = (
                  # op
		  1,
                  # htype
		  1,
                  # hlen
		  6,
                  # hops
		  0,
                  # xid
		  $xid,
                  # secs
		  0,
                  # flags
		  0,
                  # ciaddr
		  $self->{Client},
                  # yiaddr
		  0,
                  # siaddr
		  0,
                  # giaddr
		  0,
                  # chaddr
		  @{ $self->{Ether} },
		  0,  0,  0,  0,  0,  0,
		  0,  0,  0,  0,
                  # sname
		  "\0",
                  # file
		  "\0",
                  # Magic cookie (RFC)
		  99,130,83,99,
                  # option1 = DHCP-Message
		  53,
                  # length1 = 1
		  1,
                  # value1  = DHCPREQUEST
		  3
		  );
    my $query = pack(
		     # It's horrible, but it works
		     'CCCCNnna4NNNCCCCCCCCCCCCCCCCa64a128C*',
		     @fields
		     );
    my $serv_address;
    # I/O eval block
    eval {
	# SIG handling for alarm()
	local $SIG{ALRM} = sub { die "Alarm timeout\n" };
	# Send query
	alarm($self->{TimeOut})
	    if $self->{_Alarm};
	$self->{Watcher}->send($query, 0);
	alarm(0)
	    if $self->{_Alarm};
	# Get reply
	alarm($self->{TimeOut})
	    if $self->{_Alarm};
	$serv_address = $self->{Watcher}->recv($reply, 1024,  0);
	alarm(0)
	    if $self->{_Alarm};
    };
    # Die if not alarm
    if($@) {
	carp $@ unless $@ =~ /alarm/i;
    }
    # Verify
    # be sure $ret_xid is not equal to $xid
    my $ret_xid = !$xid;
    if ( $reply ) {
	$ret_xid = unpack('x4N',$reply);
    }
    # only if we've got a reply and the reply was correct all is ok.
    if ( $ret_xid == $xid ) {
	# Increment Ok count (max: 2**31-1)
	$self->{Last}->{Ok} %= 2147483647;
	$self->{Last}->{Ok}++;
	# Zero Bad
	$self->{Last}->{Bad} = 0;
    }
    else {
	# Zero ok
	$self->{Last}->{Ok} = 0;
	# Increment Bad count (max: 2**31-1)
	$self->{Last}->{Bad} %= 2147483647;
	$self->{Last}->{Bad}++;
    }
    # Get present time (GMT)
    $self->{Last}->{Time} = gmtime;
}
#
# close: just closes socket.
#
sub unwatch {
    my $self = shift;
    delete $self->{Watcher};
}
#
# Cleanup
#
sub DESTROY {
    my $self = shift;
    $self->unwatch;
}

1;
__END__