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 <ff at octo.it>
  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://noping.cc/>. Its purpose it to send C<ICMP ECHO_REQUEST>
  45 packets (also known as "ping") to a host and measure the time that elapses
  46 until the reception of an C<ICMP ECHO_REPLY> packet (also known as "pong"). If
  47 no such packet is received after a certain timeout the host is considered to be
  48 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.21';
  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<device> (I<$device>);
 175
 176 Sets the network device used for communication. This may not be supported on
 177 all platforms.
 178
 179 I<Requires liboping 1.3 or later.>
 180
 181 =cut
 182
 183 sub device
 184 {
 185   my $obj = shift;
 186   my $device = shift;
 187   my $status;
 188
 189   $status = _ping_setopt_device ($obj->{'c_obj'}, $device);
 190   if ($status == -95) # Feature not supported.
 191   {
 192     $obj->{'err_msg'} = "Feature not supported by your version of liboping.";
 193   }
 194   elsif ($status != 0)
 195   {
 196     $obj->{'err_msg'} = "" . _ping_get_error ($obj->{'c_obj'});
 197     return;
 198   }
 199
 200   return (1);
 201 }
 202
 203 =item I<$status> = I<$obj>-E<gt>B<host_add> (I<$host>, [I<$host>, ...]);
 204
 205 Adds one or more hosts to the Net::Oping-object I<$obj>. The number of
 206 successfully added hosts is returned. If this number differs from the number of
 207 hosts that were passed to the method you can use B<get_error> (see below) to
 208 get the error message of the last failure.
 209
 210 =cut
 211
 212 sub host_add
 213 {
 214   my $obj = shift;
 215   my $i;
 216
 217   $i = 0;
 218   for (@_)
 219   {
 220     my $status = _ping_host_add ($obj->{'c_obj'}, $_);
 221     if ($status != 0)
 222     {
 223       $obj->{'err_msg'} = "" . _ping_get_error ($obj->{'c_obj'});
 224     }
 225     else
 226     {
 227       $i++;
 228     }
 229   }
 230
 231   return ($i);
 232 }
 233
 234 =item I<$status> = I<$obj>-E<gt>B<host_remove> (I<$host>, [I<$host>, ...]);
 235
 236 Same semantic as B<host_add> but removes hosts.
 237
 238 =cut
 239
 240 sub host_remove
 241 {
 242   my $obj = shift;
 243   my $i;
 244
 245   $i = 0;
 246   for (@_)
 247   {
 248     my $status = _ping_host_remove ($obj->{'c_obj'}, $_);
 249     if ($status != 0)
 250     {
 251       $obj->{'err_msg'} = "" . _ping_get_error ($obj->{'c_obj'});
 252     }
 253     else
 254     {
 255       $i++;
 256     }
 257   }
 258   return ($i);
 259 }
 260
 261 =item I<$latency> = I<$obj>-E<gt>B<ping> ()
 262
 263 The central method of this module sends ICMP packets to the hosts and waits for
 264 replies. The time it takes for replies to arrive is measured and returned.
 265
 266 The returned scalar is a hash reference where each host associated with the
 267 I<$obj> object is a key and the associated value is the corresponding latency
 268 in milliseconds. An example hash reference would be:
 269
 270   $latency = { host1 => 51.143, host2 => undef, host3 => 54.697, ... };
 271
 272 If a value is C<undef>, as for "host2" in this example, the host has timed out
 273 and considered unreachable.
 274
 275 =cut
 276
 277 sub ping
 278 {
 279   my $obj = shift;
 280   my $iter;
 281   my $data = {};
 282   my $status;
 283
 284   $status = _ping_send ($obj->{'c_obj'});
 285   if ($status < 0)
 286   {
 287     $obj->{'err_msg'} = "" . _ping_get_error ($obj->{'c_obj'});
 288     return;
 289   }
 290
 291   $iter = _ping_iterator_get ($obj->{'c_obj'});
 292   if (!$iter)
 293   {
 294     $obj->{'err_msg'} = "" . _ping_get_error ($obj->{'c_obj'});
 295     return;
 296   }
 297
 298   while ($iter)
 299   {
 300     my $host = _ping_iterator_get_hostname ($iter);
 301     if (!$host)
 302     {
 303       $iter = _ping_iterator_next ($iter);
 304       next;
 305     }
 306
 307     my $latency = _ping_iterator_get_latency ($iter);
 308     if ($latency < 0.0)
 309     {
 310       $latency = undef;
 311     }
 312
 313     $data->{$host} = $latency;
 314
 315     $iter = _ping_iterator_next ($iter);
 316   }
 317
 318   return ($data);
 319 } # ping
 320
 321 =item I<$dropped> = I<$obj>-E<gt>B<get_dropped> ()
 322
 323 Returns a hash reference holding the number of "drops" (echo requests which
 324 were not answered in time) for each host. An example return
 325 values would be:
 326
 327   $droprate = { host1 => 0, host2 => 3, host3 => undef, ... };
 328
 329 Hosts to which no data has been sent yet will return C<undef> ("host3" in thie
 330 example).
 331
 332 =cut
 333
 334 sub get_dropped
 335 {
 336   my $obj = shift;
 337   my $iter;
 338   my $data = {};
 339
 340   $iter = _ping_iterator_get ($obj->{'c_obj'});
 341   if (!$iter)
 342   {
 343     $obj->{'err_msg'} = "" . _ping_get_error ($obj->{'c_obj'});
 344     return;
 345   }
 346
 347   while ($iter)
 348   {
 349     my $host = _ping_iterator_get_hostname ($iter);
 350     if (!$host)
 351     {
 352       $iter = _ping_iterator_next ($iter);
 353       next;
 354     }
 355
 356     my $dropped = _ping_iterator_get_dropped ($iter);
 357     if ($dropped < 0)
 358     {
 359       $dropped = undef;
 360     }
 361
 362     $data->{$host} = $dropped;
 363
 364     $iter = _ping_iterator_next ($iter);
 365   }
 366
 367   return ($data);
 368 } # get_dropped
 369
 370 =item I<$ttl> = I<$obj>-E<gt>B<get_recv_ttl> ()
 371
 372 Returns a hash reference holding the I<Time to Live> (TTL) of the last received
 373 packet for each host. An example return value would be:
 374
 375   $ttl = { host1 => 60, host2 => 41, host3 => 243, ... };
 376
 377 To signal an invalid or unavailable TTL, a negative number is returned.
 378
 379 =cut
 380
 381 sub get_recv_ttl
 382 {
 383   my $obj = shift;
 384   my $iter;
 385   my $data = {};
 386
 387   $iter = _ping_iterator_get ($obj->{'c_obj'});
 388   if (!$iter)
 389   {
 390     $obj->{'err_msg'} = "" . _ping_get_error ($obj->{'c_obj'});
 391     return;
 392   }
 393
 394   while ($iter)
 395   {
 396     my $host = _ping_iterator_get_hostname ($iter);
 397     if ($host)
 398     {
 399       $data->{$host} = _ping_iterator_get_recv_ttl ($iter);
 400     }
 401
 402     $iter = _ping_iterator_next ($iter);
 403   }
 404
 405   return ($data);
 406 } # get_recv_ttl
 407
 408 =item I<$errmsg> = I<$obj>-E<gt>B<get_error> ();
 409
 410 Returns the last error that occurred.
 411
 412 =cut
 413
 414 sub get_error
 415 {
 416   my $obj = shift;
 417   return ($obj->{'err_msg'} || 'Success');
 418 }
 419
 420 =back
 421
 422 =head1 CAVEATS
 423
 424 The I<oping> library opens a raw socket to be able to send ICMP packets. On
 425 most systems normal users are not allowed to do this. This is why on most
 426 systems the L<ping(1)> utility is installed as SetUID-root. Since, when using
 427 this module, no external process is spawned B<this> process needs the
 428 appropriate permissions. This means that either your script has to run as
 429 superuser or, under Linux, needs the C<CAP_NET_RAW> capability.
 430
 431 =head1 SEE ALSO
 432
 433 L<liboping(3)>
 434
 435 The I<liboping> homepage may be found at L<http://noping.cc/>.
 436 Information about its mailing list may be found at
 437 L<http://mailman.verplant.org/listinfo/liboping>.
 438
 439 =head1 AUTHORS
 440
 441 First XSE<nbsp>port by Olivier Fredj, extended XS functionality and high-level
 442 Perl interface by Florian Forster.
 443
 444 =head1 COPYRIGHT AND LICENSE
 445
 446 Copyright (C) 2007 by Olivier Fredj E<lt>ofredjE<nbsp>atE<nbsp>proxad.netE<gt>
 447
 448 Copyright (C) 2008,2009 by Florian Forster E<lt>ffE<nbsp>atE<nbsp>octo.itE<gt>
 449
 450 This library is free software; you can redistribute it and/or modify
 451 it under the same terms as Perl itself, either Perl version 5.8.7 or,
 452 at your option, any later version of Perl 5 you may have available.
 453
 454 Please note that I<liboping> is licensed under the GPLv2. Derived works of
 455 both, I<Net::Oping> and I<liboping>, (i.E<nbsp>e. binary packages) may
 456 therefore be subject to stricter licensing terms than the source code of this
 457 package.
 458
 459 =cut
 460
 461 # vim: set shiftwidth=2 softtabstop=2 tabstop=8 :