perl 5.000perl-5.000

[editor's note: this commit combines approximate 4 months of furious
releases of Andy Dougherty and Larry Wall - see pod/perlhist.pod for
details.  Andy notes that;
 
Alas neither my "Irwin AccuTrack" nor my DC 600A quarter-inch cartridge 
backup tapes from that era seem to be readable anymore.  I guess 13 years 
exceeds the shelf life for that backup technology :-(.
]

1 files changed, 64 insertions, 0 deletions

diff --git a/lib/Net/Ping.pm b/lib/Net/Ping.pm
new file mode 100644
index 0000000000..2528f55255
--- /dev/null
+++ b/lib/Net/Ping.pm
@@ -0,0 +1,64 @@
+package Net::Ping;
+
+# Authors: karrer@bernina.ethz.ch (Andreas Karrer)
+#          pmarquess@bfsec.bt.co.uk (Paul Marquess)
+
+require Exporter;
+
+@ISA = qw(Exporter);
+@EXPORT = qw(ping pingecho);
+
+use Socket;
+use Carp ;
+
+$tcp_proto = (getprotobyname('tcp'))[2];
+$echo_port = (getservbyname('echo', 'tcp'))[2];
+
+sub ping {
+    croak "ping not implemented yet. Use pingecho()";
+}
+
+
+sub pingecho {
+
+    croak "usage: pingecho host [timeout]" 
+        unless @_ == 1 || @_ == 2 ;
+
+    local ($host, $timeout) = @_;
+    local (*PINGSOCK);
+    local ($saddr, $ip);
+    local ($ret) ;
+
+    # check if $host is alive by connecting to its echo port, within $timeout
+    # (default 5) seconds. returns 1 if OK, 0 if no answer, 0 if host not found
+
+    $timeout = 5 unless $timeout;
+
+    if ($host =~ /^\s*((\d+\.){3}\d+)\s*$/)
+      { $ip = pack ('C4', split (/\./, $1)) }
+    else
+      { $ip = (gethostbyname($host))[4] }
+
+    return 0 unless $ip;		# "no such host"
+
+    $saddr = pack('S n a4 x8', AF_INET, $echo_port, $ip);
+    $SIG{'ALRM'} = sub { die } ;
+    alarm($timeout);
+
+    $ret = eval <<'EOM' ;
+
+        return 0 
+            unless socket(PINGSOCK, PF_INET, SOCK_STREAM, $tcp_proto) ;
+
+        return 0 
+            unless connect(PINGSOCK, $saddr) ;
+
+        return 1 ;
+EOM
+
+    alarm(0);
+    close(PINGSOCK);
+    $ret == 1 ? 1 : 0 ;
+}   
+
+1;