Fix a2p manpage (from Debian)

[p5sagit/p5-mst-13.2.git] / lib / Net / Ping.pm

diff --git a/lib/Net/Ping.pm b/lib/Net/Ping.pm
index f50967c..4f44106 100644 (file)
--- a/lib/Net/Ping.pm
+++ b/lib/Net/Ping.pm
@@ -16,7 +16,10 @@ use Carp;
 
 @ISA = qw(Exporter);
 @EXPORT = qw(pingecho);
-$VERSION = "2.30";
+$VERSION = "2.31";
+
+sub SOL_IP { 0; };
+sub IP_TOS { 1; };
 
 # Constants
 
@@ -74,6 +77,7 @@ sub new
       $timeout,           # Optional timeout in seconds
       $data_size,         # Optional additional bytes of data
       $device,            # Optional device to use
+      $tos,               # Optional ToS to set
       ) = @_;
   my  $class = ref($this) || $this;
   my  $self = {};
@@ -95,6 +99,8 @@ sub new
 
   $self->{"device"} = $device;
 
+  $self->{"tos"} = $tos;
+
   $min_datasize = ($proto eq "udp") ? 1 : 0;  # Determine data size
   $data_size = $min_datasize unless defined($data_size) && $proto ne "tcp";
   croak("Data for ping must be from $min_datasize to $max_datasize bytes")
@@ -127,6 +133,10 @@ sub new
       setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
         or croak "error binding to device $self->{'device'} $!";
     }
+    if ($self->{'tos'}) {
+      setsockopt($self->{"fh"}, SOL_IP, IP_TOS(), pack("I*", $self->{'tos'}))
+        or croak "error configuring tos to $self->{'tos'} $!";
+    }
   }
   elsif ($self->{"proto"} eq "icmp")
   {
@@ -141,6 +151,10 @@ sub new
       setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
         or croak "error binding to device $self->{'device'} $!";
     }
+    if ($self->{'tos'}) {
+      setsockopt($self->{"fh"}, SOL_IP, IP_TOS(), pack("I*", $self->{'tos'}))
+        or croak "error configuring tos to $self->{'tos'} $!";
+    }
   }
   elsif ($self->{"proto"} eq "tcp" || $self->{"proto"} eq "stream")
   {
@@ -203,7 +217,7 @@ sub bind
   CORE::bind($self->{"fh"}, sockaddr_in(0, $ip)) ||
     croak("$self->{'proto'} bind error - $!");
   }
-  elsif ($self->{"proto"} ne "tcp")
+  elsif (($self->{"proto"} ne "tcp") && ($self->{"proto"} ne "syn"))
   {
     croak("Unknown protocol \"$self->{proto}\" in bind()");
   }
@@ -302,9 +316,9 @@ sub socket_blocking_mode
                         # set the non-blocking mode (set O_NONBLOCK)
 
   my $flags;
-  if ($^O eq 'MSWin32') {
-      # FIONBIO enables non-blocking sockets on windows.
-      # FIONBIO is (0x80000000|(4<<16)|(ord('f')<<8)|126), as per winsock.h.
+  if ($^O eq 'MSWin32' || $^O eq 'VMS') {
+      # FIONBIO enables non-blocking sockets on windows and vms.
+      # FIONBIO is (0x80000000|(4<<16)|(ord('f')<<8)|126), as per winsock.h, ioctl.h
       my $f = 0x8004667e;
       my $v = pack("L", $block ? 0 : 1);
       ioctl($fh, $f, $v) or croak("ioctl failed: $!");
@@ -562,10 +576,16 @@ sub tcp_connect
       setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
         or croak("error binding to device $self->{'device'} $!");
     }
+    if ($self->{'tos'}) {
+      setsockopt($self->{"fh"}, SOL_IP, IP_TOS(), pack("I*", $self->{'tos'}))
+        or croak "error configuring tos to $self->{'tos'} $!";
+    }
   };
   my $do_connect = sub {
     $self->{"ip"} = $ip;
-    return ($ret = connect($self->{"fh"}, $saddr));
+    # ECONNREFUSED is 10061 on MSWin32. If we pass it as child error through $?,
+    # we'll get (10061 & 255) = 77, so we cannot check it in the parent process.
+    return ($ret = connect($self->{"fh"}, $saddr) || ($! == ECONNREFUSED && !$self->{"econnrefused"}));
   };
   my $do_connect_nb = sub {
     # Set O_NONBLOCK property on filehandle
@@ -667,7 +687,8 @@ sub tcp_connect
         exit 0;
       } else {
         # Pass the error status to the parent
-        exit $!;
+        # Make sure that $! <= 255
+        exit($! <= 255 ? $! : 255);
       }
     }
 
@@ -692,6 +713,8 @@ sub tcp_connect
         # within the timeout
         &{ $do_connect }();
       }
+      # $ret cannot be set by the child process
+      $ret = !$child_errno;
     } else {
       # Time must have run out.
       # Put that choking client out of its misery
@@ -997,7 +1020,10 @@ sub ping_syn
     setsockopt($fh, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
       or croak("error binding to device $self->{'device'} $!");
   }
-
+  if ($self->{'tos'}) {
+    setsockopt($fh, SOL_IP, IP_TOS(), pack("I*", $self->{'tos'}))
+      or croak "error configuring tos to $self->{'tos'} $!";
+  }
   # Set O_NONBLOCK property on filehandle
   $self->socket_blocking_mode($fh, 0);
 
@@ -1063,6 +1089,10 @@ sub ping_syn_fork {
         setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
           or croak("error binding to device $self->{'device'} $!");
       }
+      if ($self->{'tos'}) {
+        setsockopt($self->{"fh"}, SOL_IP, IP_TOS(), pack("I*", $self->{'tos'}))
+          or croak "error configuring tos to $self->{'tos'} $!";
+      }
 
       $!=0;
       # Try to connect (could take a long time)
@@ -1454,7 +1484,7 @@ This protocol does not require any special privileges.
 
 =over 4
 
-=item Net::Ping->new([$proto [, $def_timeout [, $bytes [, $device ]]]]);
+=item Net::Ping->new([$proto [, $def_timeout [, $bytes [, $device [, $tos ]]]]]);
 
 Create a new ping object.  All of the parameters are optional.  $proto
 specifies the protocol to use when doing a ping.  The current choices
@@ -1476,6 +1506,8 @@ If $device is given, this device is used to bind the source endpoint
 before sending the ping packet.  I beleive this only works with
 superuser privileges and with udp and icmp protocols at this time.
 
+If $tos is given, this ToS is configured into the soscket.
+
 =item $p->ping($host [, $timeout]);
 
 Ping the remote host and wait for a response.  $host can be either the
@@ -1707,6 +1739,6 @@ Copyright (c) 2001, Colin McMillen.  All rights reserved.
 This program is free software; you may redistribute it and/or
 modify it under the same terms as Perl itself.
 
-$Id: Ping.pm,v 1.81 2003/04/18 04:16:03 rob Exp $
+$Id: Ping.pm,v 1.86 2003/06/27 21:31:07 rob Exp $
 
 =cut