ping.pm

视频监控网络部分的协议ddns,的模块的实现代码,请大家大胆指正.

package Net::Ping;

require 5.002;
require Exporter;

use strict;
use vars qw(@ISA @EXPORT $VERSION
            $def_timeout $def_proto $def_factor
            $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 PF_INET SOL_SOCKET SO_ERROR
               inet_aton inet_ntoa sockaddr_in );
use POSIX qw( ENOTCONN ECONNREFUSED ECONNRESET EINPROGRESS EWOULDBLOCK EAGAIN WNOHANG );
use FileHandle;
use Carp;

@ISA = qw(Exporter);
@EXPORT = qw(pingecho);
$VERSION = "2.33";

sub SOL_IP { 0; };
sub IP_TOS { 1; };

# Constants

$def_timeout = 5;           # Default timeout to wait for a reply
$def_proto = "tcp";         # Default protocol to use for pinging
$def_factor = 1.2;          # Default exponential backoff rate.
$max_datasize = 1024;       # Maximum data bytes in a packet
# The data we exchange with the server for the stream protocol
$pingstring = "pingschwingping!\n";
$source_verify = 1;         # Default is to verify source endpoint
$syn_forking = 0;

if ($^O =~ /Win32/i) {
  # Hack to avoid this Win32 spewage:
  # Your vendor has not defined POSIX macro ECONNREFUSED
  *ECONNREFUSED = sub() {10061;}; # "Unknown Error" Special Win32 Response?
  *ENOTCONN     = sub() {10057;};
  *ECONNRESET   = sub() {10054;};
  *EINPROGRESS  = sub() {10036;};
  *EWOULDBLOCK  = sub() {10035;};
#  $syn_forking = 1;    # XXX possibly useful in < Win2K ?
};

# h2ph "asm/socket.h"
# require "asm/socket.ph";
sub SO_BINDTODEVICE {25;}

# Description:  The pingecho() subroutine is provided for backward
# compatibility with the original Net::Ping.  It accepts a host
# name/IP and an optional timeout in seconds.  Create a tcp ping
# object and try pinging the host.  The result of the ping is returned.

sub pingecho
{
  my ($host,              # Name or IP number of host to ping
      $timeout            # Optional timeout in seconds
      ) = @_;
  my ($p);                # A ping object

  $p = Net::Ping->new("tcp", $timeout);
  $p->ping($host);        # Going out of scope closes the connection
}

# Description:  The new() method creates a new ping object.  Optional
# parameters may be specified for the protocol to use, the timeout in
# seconds and the size in bytes of additional data which should be
# included in the packet.
#   After the optional parameters are checked, the data is constructed
# and a socket is opened if appropriate.  The object is returned.

sub new
{
  my ($this,
      $proto,             # Optional protocol to use for pinging
      $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 = {};
  my ($cnt,               # Count through data bytes
      $min_datasize       # Minimum data bytes required
      );

  bless($self, $class);

  $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)$/;
  $self->{"proto"} = $proto;

  $timeout = $def_timeout unless $timeout;    # Determine the timeout
  croak("Default timeout for ping must be greater than 0 seconds")
    if $timeout <= 0;
  $self->{"timeout"} = $timeout;

  $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")
    if ($data_size < $min_datasize) || ($data_size > $max_datasize);
  $data_size-- if $self->{"proto"} eq "udp";  # We provide the first byte
  $self->{"data_size"} = $data_size;

  $self->{"data"} = "";                       # Construct data bytes
  for ($cnt = 0; $cnt < $self->{"data_size"}; $cnt++)
  {
    $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

  $self->{"seq"} = 0;                         # For counting packets
  if ($self->{"proto"} eq "udp")              # Open a socket
  {
    $self->{"proto_num"} = (getprotobyname('udp'))[2] ||
      croak("Can't udp protocol by name");
    $self->{"port_num"} = (getservbyname('echo', 'udp'))[2] ||
      croak("Can't get udp echo port by name");
    $self->{"fh"} = FileHandle->new();
    socket($self->{"fh"}, PF_INET, SOCK_DGRAM,
           $self->{"proto_num"}) ||
             croak("udp 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->{'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")
  {
    croak("icmp ping requires root privilege") if ($> and $^O ne 'VMS' and $^O ne 'cygwin');
    $self->{"proto_num"} = (getprotobyname('icmp'))[2] ||
      croak("Can't get icmp protocol by name");
    $self->{"pid"} = $$ & 0xffff;           # Save lower 16 bits of pid
    $self->{"fh"} = FileHandle->new();
    socket($self->{"fh"}, PF_INET, 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->{'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")
  {
    $self->{"proto_num"} = (getprotobyname('tcp'))[2] ||
      croak("Can't get tcp protocol by name");
    $self->{"port_num"} = (getservbyname('echo', 'tcp'))[2] ||
      croak("Can't get tcp echo port by name");
    $self->{"fh"} = FileHandle->new();
  }
  elsif ($self->{"proto"} eq "syn")
  {
    $self->{"proto_num"} = (getprotobyname('tcp'))[2] ||
      croak("Can't get tcp protocol by name");
    $self->{"port_num"} = (getservbyname('echo', 'tcp'))[2] ||
      croak("Can't get tcp echo port by name");
    if ($syn_forking) {
      $self->{"fork_rd"} = FileHandle->new();
      $self->{"fork_wr"} = FileHandle->new();
      pipe($self->{"fork_rd"}, $self->{"fork_wr"});
      $self->{"fh"} = FileHandle->new();
      $self->{"good"} = {};
      $self->{"bad"} = {};
    } else {
      $self->{"wbits"} = "";
      $self->{"bad"} = {};
    }
    $self->{"syn"} = {};
    $self->{"stop_time"} = 0;
  }
  elsif ($self->{"proto"} eq "external")
  {
    # No preliminary work needs to be done.
  }

  return($self);
}

# Description: Set the local IP address from which pings will be sent.
# For ICMP and UDP pings, this calls bind() on the already-opened socket;
# for TCP pings, just saves the address to be used when the socket is
# opened.  Returns non-zero if successful; croaks on error.
sub bind
{
  my ($self,
      $local_addr         # Name or IP number of local interface
      ) = @_;
  my ($ip                 # Packed IP number of $local_addr
      );

  croak("Usage: \$p->bind(\$local_addr)") unless @_ == 2;
  croak("already bound") if defined($self->{"local_addr"}) &&
    ($self->{"proto"} eq "udp" || $self->{"proto"} eq "icmp");

  $ip = inet_aton($local_addr);
  croak("nonexistent local address $local_addr") unless defined($ip);
  $self->{"local_addr"} = $ip; # Only used if proto is tcp

  if ($self->{"proto"} eq "udp" || $self->{"proto"} eq "icmp")
  {
  CORE::bind($self->{"fh"}, sockaddr_in(0, $ip)) ||
    croak("$self->{'proto'} bind error - $!");
  }
  elsif (($self->{"proto"} ne "tcp") && ($self->{"proto"} ne "syn"))
  {
    croak("Unknown protocol \"$self->{proto}\" in bind()");
  }

  return 1;
}

# Description: A select() wrapper that compensates for platform
# peculiarities.
sub mselect
{
    if ($_[3] > 0 and $^O eq 'MSWin32') {
	# On windows, select() doesn't process the message loop,
	# but sleep() will, allowing alarm() to interrupt the latter.
	# So we chop up the timeout into smaller pieces and interleave
	# select() and sleep() calls.
	my $t = $_[3];
	my $gran = 0.5;  # polling granularity in seconds
	my @args = @_;
	while (1) {
	    $gran = $t if $gran > $t;
	    my $nfound = select($_[0], $_[1], $_[2], $gran);
	    undef $nfound if $nfound == -1;
	    $t -= $gran;
	    return $nfound if $nfound or !defined($nfound) or $t <= 0;

	    sleep(0);
	    ($_[0], $_[1], $_[2]) = @args;
	}
    }
    else {
	my $nfound = select($_[0], $_[1], $_[2], $_[3]);
	undef $nfound if $nfound == -1;
	return $nfound;
    }
}

# Description: Allow UDP source endpoint comparison to be
#              skipped for those remote interfaces that do
#              not response from the same endpoint.

sub source_verify
{
  my $self = shift;
  $source_verify = 1 unless defined
    ($source_verify = ((defined $self) && (ref $self)) ? shift() : $self);
}

# Description: Set whether or not the connect
# behavior should enforce remote service
# availability as well as reachability.

sub service_check
{
  my $self = shift;
  $self->{"econnrefused"} = 1 unless defined
    ($self->{"econnrefused"} = shift());
}

sub tcp_service_check
{
  service_check(@_);
}

# Description: Set exponential backoff for retransmission.
# Should be > 1 to retain exponential properties.
# If set to 0, retransmissions are disabled.

sub retrans
{
  my $self = shift;
  $self->{"retrans"} = shift;
}

# Description: allows the module to use milliseconds as returned by
# the Time::HiRes module

$hires = 0;
sub hires
{
  my $self = shift;
  $hires = 1 unless defined
    ($hires = ((defined $self) && (ref $self)) ? shift() : $self);
  require Time::HiRes if $hires;
}

sub time
{
  return $hires ? Time::HiRes::time() : CORE::time();
}

# Description: Sets or clears the O_NONBLOCK flag on a file handle.
sub socket_blocking_mode
{
  my ($self,
      $fh,              # the file handle whose flags are to be modified
      $block) = @_;     # if true then set the blocking
                        # mode (clear O_NONBLOCK), otherwise
                        # set the non-blocking mode (set O_NONBLOCK)

  my $flags;
  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: $!");
      return;
  }
  if ($flags = fcntl($fh, F_GETFL, 0)) {
    $flags = $block ? ($flags & ~O_NONBLOCK) : ($flags | O_NONBLOCK);
    if (!fcntl($fh, F_SETFL, $flags)) {
      croak("fcntl F_SETFL: $!");
    }
  } else {
    croak("fcntl F_GETFL: $!");
  }
}

# Description: Ping a host name or IP number with an optional timeout.
# First lookup the host, and return undef if it is not found.  Otherwise
# perform the specific ping method based on the protocol.  Return the
# result of the ping.

sub ping
{
  my ($self,
      $host,              # Name or IP number of host to ping
      $timeout,           # Seconds after which ping times out
      ) = @_;
  my ($ip,                # Packed IP number of $host
      $ret,               # The return value
      $ping_time,         # When ping began
      );

  croak("Usage: \$p->ping(\$host [, \$timeout])") unless @_ == 2 || @_ == 3;
  $timeout = $self->{"timeout"} unless $timeout;
  croak("Timeout must be greater than 0 seconds") if $timeout <= 0;

  $ip = inet_aton($host);
  return () unless defined($ip);      # Does host exist?

  # Dispatch to the appropriate routine.
  $ping_time = &time();
  if ($self->{"proto"} eq "external") {
    $ret = $self->ping_external($ip, $timeout);
  }
  elsif ($self->{"proto"} eq "udp") {
    $ret = $self->ping_udp($ip, $timeout);
  }
  elsif ($self->{"proto"} eq "icmp") {
    $ret = $self->ping_icmp($ip, $timeout);
  }
  elsif ($self->{"proto"} eq "tcp") {
    $ret = $self->ping_tcp($ip, $timeout);
  }
  elsif ($self->{"proto"} eq "stream") {
    $ret = $self->ping_stream($ip, $timeout);
  }
  elsif ($self->{"proto"} eq "syn") {
    $ret = $self->ping_syn($host, $ip, $ping_time, $ping_time+$timeout);
  } else {
    croak("Unknown protocol \"$self->{proto}\" in ping()");
  }

  return wantarray ? ($ret, &time() - $ping_time, inet_ntoa($ip)) : $ret;
}

# Uses Net::Ping::External to do an external ping.
sub ping_external {
  my ($self,
      $ip,                # Packed IP number of the host
      $timeout            # Seconds after which ping times out
     ) = @_;

  eval { require Net::Ping::External; }
    or croak('Protocol "external" not supported on your system: Net::Ping::External not found');
  return Net::Ping::External::ping(ip => $ip, timeout => $timeout);
}

use constant ICMP_ECHOREPLY   => 0; # ICMP packet types
use constant ICMP_UNREACHABLE => 3; # ICMP packet types
use constant ICMP_ECHO        => 8;
use constant ICMP_STRUCT      => "C2 n3 A"; # Structure of a minimal ICMP packet
use constant SUBCODE          => 0; # No ICMP subcode for ECHO and ECHOREPLY
use constant ICMP_FLAGS       => 0; # No special flags for send or recv
use constant ICMP_PORT        => 0; # No port with ICMP

sub ping_icmp
{
  my ($self,
      $ip,                # Packed IP number of the host
      $timeout            # Seconds after which ping times out
      ) = @_;

  my ($saddr,             # sockaddr_in with port and ip
      $checksum,          # Checksum of ICMP packet
      $msg,               # ICMP packet to send
      $len_msg,           # Length of $msg
      $rbits,             # Read bits, filehandles for reading
      $nfound,            # Number of ready filehandles found
      $finish_time,       # Time ping should be finished
      $done,              # set to 1 when we are done
      $ret,               # Return value
      $recv_msg,          # Received message including IP header
      $from_saddr,        # sockaddr_in of sender
      $from_port,         # Port packet was sent from
      $from_ip,           # Packed IP of sender
      $from_type,         # ICMP type
      $from_subcode,      # ICMP subcode
      $from_chk,          # ICMP packet checksum
      $from_pid,          # ICMP packet id
      $from_seq,          # ICMP packet sequence
      $from_msg           # ICMP message
      );

  $self->{"seq"} = ($self->{"seq"} + 1) % 65536; # Increment sequence
  $checksum = 0;                          # No checksum for starters
  $msg = pack(ICMP_STRUCT . $self->{"data_size"}, ICMP_ECHO, SUBCODE,
              $checksum, $self->{"pid"}, $self->{"seq"}, $self->{"data"});
  $checksum = Net::Ping->checksum($msg);
  $msg = pack(ICMP_STRUCT . $self->{"data_size"}, ICMP_ECHO, SUBCODE,
              $checksum, $self->{"pid"}, $self->{"seq"}, $self->{"data"});