From f10d12747cdf8b42cafcda71bd32a5a2c34b549b Mon Sep 17 00:00:00 2001 From: Reini Urban Date: Sat, 16 Apr 2016 11:50:20 +0200 Subject: [PATCH] features: icmpv6, wakeonlan, named args to new Add the icmpv6 protocol, Support named arguments for new: proto timeout data_size device tos ttl family gateway host bind retrans pingstring source_verify econnrefused. Add the wakeonlan function --- Changes | 9 +- lib/Net/Ping.pm | 250 ++++++++++++++++++++++++++++++++++-------------- t/001_new.t | 10 +- 3 files changed, 191 insertions(+), 78 deletions(-) diff --git a/Changes b/Changes index efa5b2d..8e2db63 100644 --- a/Changes +++ b/Changes @@ -1,18 +1,23 @@ CHANGES ------- -2.44 Mar 17 09:35 2013 - version in cperl since 5.22.2c +2.50 Sat Apr 16 11:50:20 2016 +0200 (rurban) + version in cperl since 5.22.2c Features - Handle IPv6 addresses and the AF_INET6 family. - Added the optional family argument to most methods. valid values: 6, "v6", "ip6", "ipv6", AF_INET6 + - new can take now named arguments, a hashref. + - Added the following named arguments to new: + gateway host bind retrans pingstring source_verify econnrefused + - Added the wakeonlan method Internals - $ip is now a hash with {addr, addr_in, family} not the addr_in packed IP. - added _resolv replacing inet_aton, _pack_sockaddr_in and _unpack_sockaddr_in replacing sockaddr_in, _inet_ntoa replacing inet_ntoa + - added several new tests (Steve Peters) 2.43 Mon Apr 29 00:23:56 2013 -0300 version in perl core since 5.19.9 diff --git a/lib/Net/Ping.pm b/lib/Net/Ping.pm index b53e89c..2317d1a 100644 --- a/lib/Net/Ping.pm +++ b/lib/Net/Ping.pm @@ -4,12 +4,12 @@ require 5.002; require Exporter; use strict; -use vars qw(@ISA @EXPORT $VERSION +use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION $def_timeout $def_proto $def_factor $def_family $max_datasize $pingstring $hires $source_verify $syn_forking); use Fcntl qw( F_GETFL F_SETFL O_NONBLOCK ); use Socket qw( SOCK_DGRAM SOCK_STREAM SOCK_RAW AF_INET PF_INET IPPROTO_TCP - SOL_SOCKET SO_ERROR + SOL_SOCKET SO_ERROR SO_BROADCAST IPPROTO_IP IP_TOS IP_TTL inet_ntoa inet_aton getnameinfo NI_NUMERICHOST sockaddr_in ); use POSIX qw( ENOTCONN ECONNREFUSED ECONNRESET EINPROGRESS EWOULDBLOCK EAGAIN @@ -20,7 +20,8 @@ use Time::HiRes; @ISA = qw(Exporter); @EXPORT = qw(pingecho); -$VERSION = "2.44"; +@EXPORT_OK = qw(wakeonlan); +$VERSION = "2.50"; # Globals @@ -40,6 +41,7 @@ my $AF_INET6 = eval { Socket::AF_INET6() }; my $AF_UNSPEC = eval { Socket::AF_UNSPEC() }; my $AI_NUMERICHOST = eval { Socket::AI_NUMERICHOST() }; my $NI_NUMERICHOST = eval { Socket::NI_NUMERICHOST() }; +my $IPPROTO_IPV6 = eval { Socket::IPPROTO_IPV6() }; my $qr_family = qr/^(?:(?:(:?ip)?v?(?:4|6))|${\AF_INET}|$AF_INET6)$/; my $qr_family4 = qr/^(?:(?:(:?ip)?v?4)|${\AF_INET})$/; @@ -99,7 +101,7 @@ sub new $device, # Optional device to use $tos, # Optional ToS to set $ttl, # Optional TTL to set - $family # Optional address family (AF_INET) + $family, # Optional address family (AF_INET) ) = @_; my $class = ref($this) || $this; my $self = {}; @@ -108,10 +110,28 @@ sub new ); bless($self, $class); + if (ref $proto eq 'HASH') { # support named args + for my $k (qw(proto timeout data_size device tos ttl family + gateway host bind retrans pingstring source_verify + econnrefused)) + { + if (exists $proto->{$k}) { + $self->{$k} = $proto->{$k}; + # some are still globals + if ($k eq 'pingstring') { $pingstring = $proto->{$k} } + if ($k eq 'source_verify') { $source_verify = $proto->{$k} } + delete $proto->{$k}; + } + } + if (%$proto) { + croak("Invalid named argument: ",join(" ",keys (%$proto))); + } + $proto = $self->{'proto'}; + } $proto = $def_proto unless $proto; # Determine the protocol - croak('Protocol for ping must be "icmp", "udp", "tcp", "syn", "stream", or "external"') - unless $proto =~ m/^(icmp|udp|tcp|syn|stream|external)$/; + croak('Protocol for ping must be "icmp", "icmpv6", "udp", "tcp", "syn", "stream" or "external"') + unless $proto =~ m/^(icmp|icmpv6|udp|tcp|syn|stream|external)$/; $self->{"proto"} = $proto; $timeout = $def_timeout unless $timeout; # Determine the timeout @@ -123,10 +143,27 @@ sub new $self->{"tos"} = $tos; - if ($self->{"proto"} eq 'icmp') { + if ($self->{'host'}) { + my $host = $self->{'host'}; + my $ip = _resolv($host) + or croak("could not resolve host $host"); + $self->{host} = $ip; + $self->{family} = $ip->{family}; + } + + if ($self->{bind}) { + my $addr = $self->{bind}; + my $ip = _resolv($addr) + or croak("could not resolve local addr $addr"); + $self->{local_addr} = $ip; + } else { + $self->{local_addr} = undef; # Don't bind by default + } + + if ($self->{proto} eq 'icmp') { croak('TTL must be from 0 to 255') if ($ttl && ($ttl < 0 || $ttl > 255)); - $self->{"ttl"} = $ttl; + $self->{ttl} = $ttl; } if ($family) { @@ -156,9 +193,10 @@ sub new $self->{"data"} .= chr($cnt % 256); } - $self->{"local_addr"} = undef; # Don't bind by default - $self->{"retrans"} = $def_factor; # Default exponential backoff rate - $self->{"econnrefused"} = undef; # Default Connection refused behavior + # Default exponential backoff rate + $self->{"retrans"} = $def_factor unless exists $self->{"retrans"}; + # Default Connection refused behavior + $self->{"econnrefused"} = undef unless exists $self->{"econnrefused"}; $self->{"seq"} = 0; # For counting packets if ($self->{"proto"} eq "udp") # Open a socket @@ -202,6 +240,43 @@ sub new or croak "error configuring ttl to $self->{'ttl'} $!"; } } + elsif ($self->{"proto"} eq "icmpv6") + { + croak("icmpv6 ping requires root privilege") if ($> and $^O ne 'VMS' and $^O ne 'cygwin'); + croak("Wrong family $self->{family} for icmpv6 protocol") + if $self->{"family"} and $self->{"family"} != $AF_INET6; + $self->{"family"} != $AF_INET6; + $self->{"proto_num"} = eval { (getprotobyname('ipv6-icmp'))[2] } || + croak("Can't get ipv6-icmp protocol by name"); # 58 + $self->{"pid"} = $$ & 0xffff; # Save lower 16 bits of pid + $self->{"fh"} = FileHandle->new(); + socket($self->{"fh"}, $AF_INET6, SOCK_RAW, $self->{"proto_num"}) || + croak("icmp socket error - $!"); + if ($self->{'device'}) { + setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'})) + or croak "error binding to device $self->{'device'} $!"; + } + if ($self->{'gateway'}) { + my $g = $self->{gateway}; + my $ip = _resolv($g) + or croak("nonexistent gateway $g"); + $self->{family} eq $AF_INET6 + or croak("gateway requires the AF_INET6 family"); + $ip->{family} eq $AF_INET6 + or croak("gateway address needs to be IPv6"); + my $IPV6_NEXTHOP = eval { Socket::IPV6_NEXTHOP() } || 48; # IPV6_3542NEXTHOP, or 21 + setsockopt($self->{"fh"}, $IPPROTO_IPV6, $IPV6_NEXTHOP, _pack_sockaddr_in($ip)) + or croak "error configuring gateway to $g NEXTHOP $!"; + } + if ($self->{'tos'}) { + setsockopt($self->{"fh"}, IPPROTO_IP, IP_TOS, pack("I*", $self->{'tos'})) + or croak "error configuring tos to $self->{'tos'} $!"; + } + if ($self->{'ttl'}) { + setsockopt($self->{"fh"}, IPPROTO_IP, IP_TTL, pack("I*", $self->{'ttl'})) + or croak "error configuring ttl to $self->{'ttl'} $!"; + } + } elsif ($self->{"proto"} eq "tcp" || $self->{"proto"} eq "stream") { $self->{"proto_num"} = eval { (getprotobyname('tcp'))[2] } || @@ -393,7 +468,8 @@ sub ping $ping_time, # When ping began ); - croak("Usage: \$p->ping(\$host [, \$timeout [, \$family]])") unless @_ == 2 || @_ == 3 || @_ == 4; + $host = $self->{host} if !defined $host and $self->{host}; + croak("Usage: \$p->ping([ \$host [, \$timeout [, \$family]]])") if @_ > 4 or !$host; $timeout = $self->{"timeout"} unless $timeout; croak("Timeout must be greater than 0 seconds") if $timeout <= 0; @@ -1527,6 +1603,27 @@ sub ntop { return $address; } +sub wakeonlan { + my ($mac_addr, $host, $port) = @_; + + # use the discard service if $port not passed in + if (! defined $host) { $host = '255.255.255.255' } + if (! defined $port || $port !~ /^\d+$/ ) { $port = 9 } + + my $sock = new IO::Socket::INET(Proto=>'udp') || return undef; + + my $ip_addr = inet_aton($host); + my $sock_addr = sockaddr_in($port, $ip_addr); + $mac_addr =~ s/://g; + my $packet = pack('C6H*', 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, $mac_addr x 16); + + setsockopt($sock, SOL_SOCKET, SO_BROADCAST, 1); + send($sock, $packet, 0, $sock_addr); + close ($sock); + + return 1; +} + ######################################################## # DNS hostname resolution # return: @@ -1828,55 +1925,56 @@ This protocol does not require any special privileges. =over 4 -=item Net::Ping->new([$proto [, $def_timeout [, $bytes [, $device [, $tos [, $ttl [, $family ]]]]]]]); +=item Net::Ping->new([proto, timeout, bytes, device, tos, ttl, family, + host, bind, gateway, retrans, pingstring, source_verify, + econnrefused]) + +Create a new ping object. All of the parameters are optional and can +be passed as hash ref. All options besides the first 7 must be passed +as hash ref. -Create a new ping object. All of the parameters are optional. $proto -specifies the protocol to use when doing a ping. The current choices -are "tcp", "udp", "icmp", "stream", "syn", or "external". -The default is "tcp". +C specifies the protocol to use when doing a ping. The current +choices are "tcp", "udp", "icmp", "icmpv6", "stream", "syn", or +"external". The default is "tcp". -If a default timeout ($def_timeout) in seconds is provided, it is used +If a C in seconds is provided, it is used when a timeout is not given to the ping() method (below). The timeout must be greater than 0 and the default, if not specified, is 5 seconds. -If the number of data bytes ($bytes) is given, that many data bytes +If the number of data bytes (C) is given, that many data bytes are included in the ping packet sent to the remote host. The number of data bytes is ignored if the protocol is "tcp". The minimum (and default) number of data bytes is 1 if the protocol is "udp" and 0 otherwise. The maximum number of data bytes that can be specified is 1024. -If $device is given, this device is used to bind the source endpoint +If C is given, this device is used to bind the source endpoint before sending the ping packet. I believe 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 socket. +If is given, this ToS is configured into the socket. -For icmp, $ttl can be specified to set the TTL of the outgoing packet. +For icmp, C can be specified to set the TTL of the outgoing packet. -=over 4 +Valid C values for IPv4: -Valid $family values for IPv4: + 4, v4, ip4, ipv4, AF_INET (constant) -=over 4 +Valid C values for IPv6: -4, v4, ip4, ipv4, AF_INET (constant) + 6, v6, ip6, ipv6, AF_INET6 (constant) -=back +The C argument implicitly specifies the family if the family +argument is not given. -=back - -=over 4 +The C argument specifies the local_addr to bind to. +By specifying a bind argument you don't need the bind method. -Valid values for IPv6: +The C argument is only valid for IPv6, and requires a IPv6 +address. -=over 4 - -6, v6, ip6, ipv6, AF_INET6 (constant) - -=back - -=back +The C argument the exponential backoff rate, default 1.2. +It matches the $def_factor global. =item $p->ping($host [, $timeout [, $family]]); @@ -1933,7 +2031,7 @@ Deprecated method, but does the same as service_check() method. =item $p->hires( { 0 | 1 } ); -Causes this module to use Time::HiRes module, allowing milliseconds +With 1 causes this module to use Time::HiRes module, allowing milliseconds to be returned by subsequent calls to ping(). This is disabled by default. @@ -2012,6 +2110,17 @@ return values and parameters are the same as described for the ping() method. This subroutine is obsolete and may be removed in a future version of Net::Ping. +=item wakeonlan($mac, [$host, [$port]]) + +Emit the popular wake-on-lan magic udp packet to wake up a local +device. See also L, but this has the mac address as 1st arg. +$host should be the local gateway. Without it will broadcast. + +Default host: '255.255.255.255' +Default port: 9 + + perl -MNet::Ping=wakeonlan -e'wakeonlan "e0:69:95:35:68:d2"' + =back =head1 NOTES @@ -2023,9 +2132,10 @@ either udp or icmp. If many hosts are pinged frequently, you may wish to implement a small wait (e.g. 25ms or more) between each ping to avoid flooding your network with packets. -The icmp protocol requires that the program be run as root or that it -be setuid to root. The other protocols do not require special -privileges, but not all network devices implement tcp or udp echo. +The icmp and icmpv6 protocols requires that the program be run as root +or that it be setuid to root. The other protocols do not require +special privileges, but not all network devices implement tcp or udp +echo. Local hosts should normally respond to pings within milliseconds. However, on a very congested network it may take up to 3 seconds or @@ -2045,57 +2155,44 @@ kinds of ICMP packets. =head1 INSTALL -The latest source tree is available via cvs: +The latest source tree is available via git: - cvs -z3 -q -d \ - :pserver:anonymous@cvs.roobik.com.:/usr/local/cvsroot/freeware \ - checkout Net-Ping + git clone https://github.com/rurban/net-ping.git Net-Ping cd Net-Ping The tarball can be created as follows: perl Makefile.PL ; make ; make dist -The latest Net::Ping release can be found at CPAN: - - $CPAN/modules/by-module/Net/ - -1) Extract the tarball - - gtar -zxvf Net-Ping-xxxx.tar.gz - cd Net-Ping-xxxx - -2) Build: +The latest Net::Ping releases are included in cperl and perl5. - make realclean - perl Makefile.PL - make - make test - -3) Install - - make install +=head1 BUGS -Or install it RPM Style: +For a list of known issues, visit: - rpm -ta SOURCES/Net-Ping-xxxx.tar.gz +L - rpm -ih RPMS/noarch/perl-Net-Ping-xxxx.rpm +To report a new bug, visit: -=head1 BUGS +L (stale) -For a list of known issues, visit: +or call: -https://rt.cpan.org/NoAuth/Bugs.html?Dist=Net-Ping + perlbug -To report a new bug, visit: +resp.: -https://rt.cpan.org/NoAuth/ReportBug.html?Queue=Net-Ping + cperlbug =head1 AUTHORS - Current maintainer: + Current maintainers: + perl11 (for cperl, with IPv6 support and more) + p5p (for perl5) + + Previous maintainers: bbb@cpan.org (Rob Brown) + Steve Peters External protocol: colinm@cpan.org (Colin McMillen) @@ -2103,6 +2200,9 @@ https://rt.cpan.org/NoAuth/ReportBug.html?Queue=Net-Ping Stream protocol: bronson@trestle.com (Scott Bronson) + Wake-on-lan: + 1999-2003 Clinton Wong + Original pingecho(): karrer@bernina.ethz.ch (Andreas Karrer) pmarquess@bfsec.bt.co.uk (Paul Marquess) @@ -2112,6 +2212,10 @@ https://rt.cpan.org/NoAuth/ReportBug.html?Queue=Net-Ping =head1 COPYRIGHT +Copyright (c) 2016, cPanel Inc. All rights reserved. + +Copyright (c) 2012, Steve Peters. All rights reserved. + Copyright (c) 2002-2003, Rob Brown. All rights reserved. Copyright (c) 2001, Colin McMillen. All rights reserved. diff --git a/t/001_new.t b/t/001_new.t index 451dcb4..d1c651d 100644 --- a/t/001_new.t +++ b/t/001_new.t @@ -12,11 +12,15 @@ isa_ok($p, "Net::Ping"); my $p2 = $p->new(); isa_ok($p2, "Net::Ping"); +# named args +my $p3 = Net::Ping->new({proto => 'tcp', ttl => 5}); +isa_ok($p3, "Net::Ping"); + # check for invalid proto eval { $p = Net::Ping->new("thwackkk"); }; -like($@, qr/Protocol for ping must be "icmp", "udp", "tcp", "syn", "stream", or "external"/, "new() errors for invalid protocol"); +like($@, qr/Protocol for ping must be "icmp", "icmpv6", "udp", "tcp", "syn", "stream" or "external"/, "new() errors for invalid protocol"); # check for invalid timeout eval { @@ -48,13 +52,13 @@ SKIP: { } else { isa_ok($p, "Net::Ping"); } - + # set IP TOS to "Minimum Delay" $p = Net::Ping->new("icmp", undef, undef, undef, 8); isa_ok($p, "Net::Ping"); # This really shouldn't work. Not sure who to blame. - $p = Net::Ping->new("icmp", undef, undef, undef, "does this fail"); + $p = Net::Ping->new("icmp", undef, undef, undef, "does this fail"); isa_ok($p, "Net::Ping"); }