bindings/perl/lib/Net/Oping.pm

   1 #
   2 # Net-Oping - lib/Net/Oping.pm
   3 # Copyright (C) 2007       Olivier Fredj
   4 # Copyright (C) 2008,2009  Florian octo Forster
   5 #
   6 # This program is free software; you can redistribute it and/or modify
   7 # it under the terms of the GNU General Public License as published by
   8 # the Free Software Foundation; only version 2 of the License is
   9 # applicable.
  10 #
  11 # This program is distributed in the hope that it will be useful,
  12 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 # GNU General Public License for more details.
  15 #
  16 # You should have received a copy of the GNU General Public License
  17 # along with this program; if not, write to the Free Software
  18 # Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  19 #
  20 # Authors:
  21 #   Olivier Fredj <ofredj at proxad.net>
  22 #   Florian octo Forster <octo at verplant.org>
  23 #
  24
  25 package Net::Oping;
  26
  27 =head1 NAME
  28
  29 Net::Oping - ICMP latency measurement module using the oping library.
  30
  31 =head1 SYNOPSIS
  32
  33   use Net::Oping;
  34
  35   my $obj = Net::Oping->new ();
  36   $obj->host_add (qw(one.example.org two.example.org));
  37
  38   my $ret = $obj->ping ();
  39   print "Latency to `one' is " . $ret->{'one.example.org'} . "\n";
  40
  41 =head1 DESCRIPTION
  42
  43 This Perl module is a high-level interface to the
  44 L<oping library|http://verplant.org/liboping/>. Its purpose it to send
  45 C<ICMP ECHO_REQUEST> packets (also known as "ping") to a host and measure the
  46 time that elapses until the reception of an C<ICMP ECHO_REPLY> packet (also
  47 known as "pong"). If no such packet is received after a certain timeout the
  48 host is considered to be unreachable.
  49
  50 The used I<oping> library supports "ping"ing multiple hosts in parallel and
  51 works with IPv4 and IPv6 transparently. Other advanced features that are
  52 provided by the underlying library, such as setting the data sent, are not yet
  53 supported by this interface.
  54
  55 =cut
  56
  57 use 5.006;
  58
  59 use strict;
  60 use warnings;
  61
  62 use Carp (qw(cluck confess));
  63
  64 our $VERSION = '1.02';
  65
  66 require XSLoader;
  67 XSLoader::load ('Net::Oping', $VERSION);
  68 return (1);
  69
  70 =head1 INTERFACE
  71
  72 The interface is kept simple and clean. First you need to create an object to
  73 which you then add hosts. Using the C<ping> method you can request a latency
  74 measurement and get the current values returned. If necessary you can remove
  75 hosts from the object, too.
  76
  77 The constructor and methods are defined as follows:
  78
  79 =over 4
  80
  81 =item I<$obj> = Net::Oping-E<gt>B<new> ();
  82
  83 Creates and returns a new object.
  84
  85 =cut
  86
  87 sub new
  88 {
  89   my $pkg = shift;
  90   my $ping_obj = _ping_construct ();
  91
  92   my $obj = bless ({ c_obj => $ping_obj }, $pkg);
  93   return ($obj);
  94 }
  95
  96 sub DESTROY
  97 {
  98   my $obj = shift;
  99   _ping_destroy ($obj->{'c_obj'});
 100 }
 101
 102 =item I<$status> = I<$obj>-E<gt>B<timeout> (I<$timeout>);
 103
 104 Sets the timeout before a host is considered unreachable to I<$timeout>
 105 seconds, which may be a floating point number to specify fractional seconds.
 106
 107 =cut
 108
 109 sub timeout
 110 {
 111   my $obj = shift;
 112   my $timeout = shift;
 113   my $status;
 114
 115   $status = _ping_setopt_timeout ($obj->{'c_obj'}, $timeout);
 116   if ($status != 0)
 117   {
 118     $obj->{'err_msg'} = "" . _ping_get_error ($obj->{'c_obj'});
 119     return;
 120   }
 121
 122   return (1);
 123 }
 124
 125 =item I<$status> = I<$obj>-E<gt>B<ttl> (I<$ttl>);
 126
 127 Sets the I<Time to Live> (TTL) of outgoing packets. I<$ttl> must be in the
 128 range B<1>E<nbsp>...E<nbsp>B<255>. Returns true when successful and false
 129 when an error occurred.
 130
 131 =cut
 132
 133 sub ttl
 134 {
 135   my $obj = shift;
 136   my $ttl = shift;
 137   my $status;
 138
 139   $status = _ping_setopt_ttl ($obj->{'c_obj'}, $ttl);
 140   if ($status != 0)
 141   {
 142     $obj->{'err_msg'} = "" . _ping_get_error ($obj->{'c_obj'});
 143     return;
 144   }
 145
 146   return (1);
 147 }
 148
 149 =item I<$status> = I<$obj>-E<gt>B<bind> (I<$ip_addr>);
 150
 151 Sets the source IP-address to use. I<$ip_addr> must be a string containing an
 152 IP-address, such as "192.168.0.1" or "2001:f00::1". As a side-effect this will
 153 set the address-family (IPv4 or IPv6) to a fixed value, too, for obvious
 154 reasons.
 155
 156 =cut
 157
 158 sub bind
 159 {
 160   my $obj = shift;
 161   my $addr = shift;
 162   my $status;
 163
 164   $status = _ping_setopt_source ($obj->{'c_obj'}, $addr);
 165   if ($status != 0)
 166   {
 167     $obj->{'err_msg'} = "" . _ping_get_error ($obj->{'c_obj'});
 168     return;
 169   }
 170
 171   return (1);
 172 }
 173
 174 =item I<$status> = I<$obj>-E<gt>B<host_add> (I<$host>, [I<$host>, ...]);
 175
 176 Adds one or more hosts to the Net::Oping-object I<$obj>. The number of
 177 successfully added hosts is returned. If this number differs from the number of
 178 hosts that were passed to the method you can use B<get_error> (see below) to
 179 get the error message of the last failure.
 180
 181 =cut
 182
 183 sub host_add
 184 {
 185   my $obj = shift;
 186   my $i;
 187
 188   $i = 0;
 189   for (@_)
 190   {
 191     my $status = _ping_host_add ($obj->{'c_obj'}, $_);
 192     if ($status != 0)
 193     {
 194       $obj->{'err_msg'} = "" . _ping_get_error ($obj->{'c_obj'});
 195     }
 196     else
 197     {
 198       $i++;
 199     }
 200   }
 201
 202   return ($i);
 203 }
 204
 205 =item I<$status> = I<$obj>-E<gt>B<host_remove> (I<$host>, [I<$host>, ...]);
 206
 207 Same semantic as B<host_add> but removes hosts.
 208
 209 =cut
 210
 211 sub host_remove
 212 {
 213   my $obj = shift;
 214   my $i;
 215
 216   $i = 0;
 217   for (@_)
 218   {
 219     my $status = _ping_host_remove ($obj->{'c_obj'}, $_);
 220     if ($status != 0)
 221     {
 222       $obj->{'err_msg'} = "" . _ping_get_error ($obj->{'c_obj'});
 223     }
 224     else
 225     {
 226       $i++;
 227     }
 228   }
 229   return ($i);
 230 }
 231
 232 =item I<$latency> = I<$obj>-E<gt>B<ping> ()
 233
 234 The central method of this module sends ICMP packets to the hosts and waits for
 235 replies. The time it takes for replies to arrive is measured and returned.
 236
 237 The returned scalar is a hash reference where each host associated with the
 238 I<$obj> object is a key and the associated value is the corresponding latency
 239 in milliseconds. An example hash reference would be:
 240
 241   $latency = { host1 => 51.143, host2 => undef, host3 => 54.697, ... };
 242
 243 If a value is C<undef>, as for "host2" in this example, the host has timed out
 244 and considered unreachable.
 245
 246 =cut
 247
 248 sub ping
 249 {
 250   my $obj = shift;
 251   my $iter;
 252   my $data = {};
 253   my $status;
 254
 255   $status = _ping_send ($obj->{'c_obj'});
 256   if ($status < 0)
 257   {
 258     $obj->{'err_msg'} = "" . _ping_get_error ($obj->{'c_obj'});
 259     return;
 260   }
 261
 262   $iter = _ping_iterator_get ($obj->{'c_obj'});
 263   if (!$iter)
 264   {
 265     $obj->{'err_msg'} = "" . _ping_get_error ($obj->{'c_obj'});
 266     return;
 267   }
 268
 269   while ($iter)
 270   {
 271     my $host = _ping_iterator_get_hostname ($iter);
 272     if (!$host)
 273     {
 274       $iter = _ping_iterator_next ($iter);
 275       next;
 276     }
 277
 278     my $latency = _ping_iterator_get_latency ($iter);
 279     if ($latency < 0.0)
 280     {
 281       $latency = undef;
 282     }
 283
 284     $data->{$host} = $latency;
 285
 286     $iter = _ping_iterator_next ($iter);
 287   }
 288
 289   return ($data);
 290 } # ping
 291
 292 =item I<$dropped> = I<$obj>-E<gt>B<get_dropped> ()
 293
 294 Returns a hash reference holding the number of "drops" (echo requests which
 295 were not answered in time) for each host. An example return
 296 values would be:
 297
 298   $droprate = { host1 => 0, host2 => 3, host3 => undef, ... };
 299
 300 Hosts to which no data has been sent yet will return C<undef> ("host3" in thie
 301 example).
 302
 303 =cut
 304
 305 sub get_dropped
 306 {
 307   my $obj = shift;
 308   my $iter;
 309   my $data = {};
 310
 311   $iter = _ping_iterator_get ($obj->{'c_obj'});
 312   if (!$iter)
 313   {
 314     $obj->{'err_msg'} = "" . _ping_get_error ($obj->{'c_obj'});
 315     return;
 316   }
 317
 318   while ($iter)
 319   {
 320     my $host = _ping_iterator_get_hostname ($iter);
 321     if (!$host)
 322     {
 323       $iter = _ping_iterator_next ($iter);
 324       next;
 325     }
 326
 327     my $dropped = _ping_iterator_get_dropped ($iter);
 328     if ($dropped < 0)
 329     {
 330       $dropped = undef;
 331     }
 332
 333     $data->{$host} = $dropped;
 334
 335     $iter = _ping_iterator_next ($iter);
 336   }
 337
 338   return ($data);
 339 } # get_dropped
 340
 341 =item I<$ttl> = I<$obj>-E<gt>B<get_recv_ttl> ()
 342
 343 Returns a hash reference holding the I<Time to Live> (TTL) of the last received
 344 packet for each host. An example return value would be:
 345
 346   $ttl = { host1 => 60, host2 => 41, host3 => 243, ... };
 347
 348 To signal an invalid or unavailable TTL, a negative number is returned.
 349
 350 =cut
 351
 352 sub get_recv_ttl
 353 {
 354   my $obj = shift;
 355   my $iter;
 356   my $data = {};
 357
 358   $iter = _ping_iterator_get ($obj->{'c_obj'});
 359   if (!$iter)
 360   {
 361     $obj->{'err_msg'} = "" . _ping_get_error ($obj->{'c_obj'});
 362     return;
 363   }
 364
 365   while ($iter)
 366   {
 367     my $host = _ping_iterator_get_hostname ($iter);
 368     if ($host)
 369     {
 370       $data->{$host} = _ping_iterator_get_recv_ttl ($iter);
 371     }
 372
 373     $iter = _ping_iterator_next ($iter);
 374   }
 375
 376   return ($data);
 377 } # get_recv_ttl
 378
 379 =item I<$errmsg> = I<$obj>-E<gt>B<get_error> ();
 380
 381 Returns the last error that occurred.
 382
 383 =cut
 384
 385 sub get_error
 386 {
 387   my $obj = shift;
 388   return ($obj->{'err_msg'} || 'Success');
 389 }
 390
 391 =back
 392
 393 =head1 CAVEATS
 394
 395 The I<oping> library opens a raw socket to be able to send ICMP packets. On
 396 most systems normal users are not allowed to do this. This is why on most
 397 systems the L<ping(1)> utility is installed as SetUID-root. Since, when using
 398 this module, no external process is spawned B<this> process needs the
 399 appropriate permissions. This means that either your script has to run as
 400 superuser or, under Linux, needs the C<CAP_NET_RAW> capability.
 401
 402 =head1 SEE ALSO
 403
 404 L<liboping(3)>
 405
 406 The I<liboping> homepage may be found at L<http://verplant.org/liboping/>.
 407 Information about its mailing list may be found at
 408 L<http://mailman.verplant.org/listinfo/liboping>.
 409
 410 =head1 AUTHOR
 411
 412 First XSE<nbsp>port by Olivier Fredj, extended XS functionality and high-level
 413 Perl interface by Florian Forster.
 414
 415 =head1 COPYRIGHT AND LICENSE
 416
 417 Copyright (C) 2007 by Olivier Fredj E<lt>ofredjE<nbsp>atE<nbsp>proxad.netE<gt>
 418
 419 Copyright (C) 2008,2009 by Florian Forster
 420 E<lt>octoE<nbsp>atE<nbsp>verplant.orgE<gt>
 421
 422 This library is free software; you can redistribute it and/or modify
 423 it under the same terms as Perl itself, either Perl version 5.8.7 or,
 424 at your option, any later version of Perl 5 you may have available.
 425
 426 Please note that I<liboping> is licensed under the GPLv2. Derived works of
 427 both, I<Net::Oping> and I<liboping>, (i.E<nbsp>e. binary packages) may
 428 therefore be subject to stricter licensing terms than the source code of this
 429 package.
 430
 431 =cut
 432
 433 # vim: set shiftwidth=2 softtabstop=2 tabstop=8 :