ping.pm

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

  $len_msg = length($msg);
  $saddr = sockaddr_in(ICMP_PORT, $ip);
  $self->{"from_ip"} = undef;
  $self->{"from_type"} = undef;
  $self->{"from_subcode"} = undef;
  send($self->{"fh"}, $msg, ICMP_FLAGS, $saddr); # Send the message

  $rbits = "";
  vec($rbits, $self->{"fh"}->fileno(), 1) = 1;
  $ret = 0;
  $done = 0;
  $finish_time = &time() + $timeout;      # Must be done by this time
  while (!$done && $timeout > 0)          # Keep trying if we have time
  {
    $nfound = mselect((my $rout=$rbits), undef, undef, $timeout); # Wait for packet
    $timeout = $finish_time - &time();    # Get remaining time
    if (!defined($nfound))                # Hmm, a strange error
    {
      $ret = undef;
      $done = 1;
    }
    elsif ($nfound)                     # Got a packet from somewhere
    {
      $recv_msg = "";
      $from_pid = -1;
      $from_seq = -1;
      $from_saddr = recv($self->{"fh"}, $recv_msg, 1500, ICMP_FLAGS);
      ($from_port, $from_ip) = sockaddr_in($from_saddr);
      ($from_type, $from_subcode) = unpack("C2", substr($recv_msg, 20, 2));
      if ($from_type == ICMP_ECHOREPLY) {
        ($from_pid, $from_seq) = unpack("n3", substr($recv_msg, 24, 4))
          if length $recv_msg >= 28;
      } else {
        ($from_pid, $from_seq) = unpack("n3", substr($recv_msg, 52, 4))
          if length $recv_msg >= 56;
      }
      $self->{"from_ip"} = $from_ip;
      $self->{"from_type"} = $from_type;
      $self->{"from_subcode"} = $from_subcode;
      if (($from_pid == $self->{"pid"}) && # Does the packet check out?
          (! $source_verify || (inet_ntoa($from_ip) eq inet_ntoa($ip))) &&
          ($from_seq == $self->{"seq"})) {
        if ($from_type == ICMP_ECHOREPLY) {
          $ret = 1;
	  $done = 1;
        } elsif ($from_type == ICMP_UNREACHABLE) {
          $done = 1;
        }
      }
    } else {     # Oops, timed out
      $done = 1;
    }
  }
  return $ret;
}

sub icmp_result {
  my ($self) = @_;
  my $ip = $self->{"from_ip"} || "";
  $ip = "\0\0\0\0" unless 4 == length $ip;
  return (inet_ntoa($ip),($self->{"from_type"} || 0), ($self->{"from_subcode"} || 0));
}

# Description:  Do a checksum on the message.  Basically sum all of
# the short words and fold the high order bits into the low order bits.

sub checksum
{
  my ($class,
      $msg            # The message to checksum
      ) = @_;
  my ($len_msg,       # Length of the message
      $num_short,     # The number of short words in the message
      $short,         # One short word
      $chk            # The checksum
      );

  $len_msg = length($msg);
  $num_short = int($len_msg / 2);
  $chk = 0;
  foreach $short (unpack("n$num_short", $msg))
  {
    $chk += $short;
  }                                           # Add the odd byte in
  $chk += (unpack("C", substr($msg, $len_msg - 1, 1)) << 8) if $len_msg % 2;
  $chk = ($chk >> 16) + ($chk & 0xffff);      # Fold high into low
  return(~(($chk >> 16) + $chk) & 0xffff);    # Again and complement
}


# Description:  Perform a tcp echo ping.  Since a tcp connection is
# host specific, we have to open and close each connection here.  We
# can't just leave a socket open.  Because of the robust nature of
# tcp, it will take a while before it gives up trying to establish a
# connection.  Therefore, we use select() on a non-blocking socket to
# check against our timeout.  No data bytes are actually
# sent since the successful establishment of a connection is proof
# enough of the reachability of the remote host.  Also, tcp is
# expensive and doesn't need our help to add to the overhead.

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

  $! = 0;
  $ret = $self -> tcp_connect( $ip, $timeout);
  if (!$self->{"econnrefused"} &&
      $! == ECONNREFUSED) {
    $ret = 1;  # "Connection refused" means reachable
  }
  $self->{"fh"}->close();
  return $ret;
}

sub tcp_connect
{
  my ($self,
      $ip,                # Packed IP number of the host
      $timeout            # Seconds after which connect times out
      ) = @_;
  my ($saddr);            # Packed IP and Port

  $saddr = sockaddr_in($self->{"port_num"}, $ip);

  my $ret = 0;            # Default to unreachable

  my $do_socket = sub {
    socket($self->{"fh"}, PF_INET, SOCK_STREAM, $self->{"proto_num"}) ||
      croak("tcp socket error - $!");
    if (defined $self->{"local_addr"} &&
        !CORE::bind($self->{"fh"}, sockaddr_in(0, $self->{"local_addr"}))) {
      croak("tcp bind 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'} $!";
    }
  };
  my $do_connect = sub {
    $self->{"ip"} = $ip;
    # 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
    $self->socket_blocking_mode($self->{"fh"}, 0);

    # start the connection attempt
    if (!connect($self->{"fh"}, $saddr)) {
      if ($! == ECONNREFUSED) {
        $ret = 1 unless $self->{"econnrefused"};
      } elsif ($! != EINPROGRESS && ($^O ne 'MSWin32' || $! != EWOULDBLOCK)) {
        # EINPROGRESS is the expected error code after a connect()
        # on a non-blocking socket.  But if the kernel immediately
        # determined that this connect() will never work,
        # Simply respond with "unreachable" status.
        # (This can occur on some platforms with errno
        # EHOSTUNREACH or ENETUNREACH.)
        return 0;
      } else {
        # Got the expected EINPROGRESS.
        # Just wait for connection completion...
        my ($wbits, $wout, $wexc);
        $wout = $wexc = $wbits = "";
        vec($wbits, $self->{"fh"}->fileno, 1) = 1;

        my $nfound = mselect(undef,
			    ($wout = $wbits),
			    ($^O eq 'MSWin32' ? ($wexc = $wbits) : undef),
			    $timeout);
        warn("select: $!") unless defined $nfound;

        if ($nfound && vec($wout, $self->{"fh"}->fileno, 1)) {
          # the socket is ready for writing so the connection
          # attempt completed. test whether the connection
          # attempt was successful or not

          if (getpeername($self->{"fh"})) {
            # Connection established to remote host
            $ret = 1;
          } else {
            # TCP ACK will never come from this host
            # because there was an error connecting.

            # This should set $! to the correct error.
            my $char;
            sysread($self->{"fh"},$char,1);
            $! = ECONNREFUSED if ($! == EAGAIN && $^O =~ /cygwin/i);

            $ret = 1 if (!$self->{"econnrefused"}
                         && $! == ECONNREFUSED);
          }
        } else {
          # the connection attempt timed out (or there were connect
	  # errors on Windows)
	  if ($^O =~ 'MSWin32') {
	      # If the connect will fail on a non-blocking socket,
	      # winsock reports ECONNREFUSED as an exception, and we
	      # need to fetch the socket-level error code via getsockopt()
	      # instead of using the thread-level error code that is in $!.
	      if ($nfound && vec($wexc, $self->{"fh"}->fileno, 1)) {
		  $! = unpack("i", getsockopt($self->{"fh"}, SOL_SOCKET,
			                      SO_ERROR));
	      }
	  }
        }
      }
    } else {
      # Connection established to remote host
      $ret = 1;
    }

    # Unset O_NONBLOCK property on filehandle
    $self->socket_blocking_mode($self->{"fh"}, 1);
    $self->{"ip"} = $ip;
    return $ret;
  };

  if ($syn_forking) {
    # Buggy Winsock API doesn't allow nonblocking connect.
    # Hence, if our OS is Windows, we need to create a separate
    # process to do the blocking connect attempt.
    # XXX Above comments are not true at least for Win2K, where
    # nonblocking connect works.

    $| = 1; # Clear buffer prior to fork to prevent duplicate flushing.
    $self->{'tcp_chld'} = fork;
    if (!$self->{'tcp_chld'}) {
      if (!defined $self->{'tcp_chld'}) {
        # Fork did not work
        warn "Fork error: $!";
        return 0;
      }
      &{ $do_socket }();

      # Try a slow blocking connect() call
      # and report the status to the parent.
      if ( &{ $do_connect }() ) {
        $self->{"fh"}->close();
        # No error
        exit 0;
      } else {
        # Pass the error status to the parent
        # Make sure that $! <= 255
        exit($! <= 255 ? $! : 255);
      }
    }

    &{ $do_socket }();

    my $patience = &time() + $timeout;

    my ($child, $child_errno);
    $? = 0; $child_errno = 0;
    # Wait up to the timeout
    # And clean off the zombie
    do {
      $child = waitpid($self->{'tcp_chld'}, &WNOHANG());
      $child_errno = $? >> 8;
      select(undef, undef, undef, 0.1);
    } while &time() < $patience && $child != $self->{'tcp_chld'};

    if ($child == $self->{'tcp_chld'}) {
      if ($self->{"proto"} eq "stream") {
        # We need the socket connected here, in parent
        # Should be safe to connect because the child finished
        # 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
      kill "KILL", $self->{'tcp_chld'};
      # Clean off the zombie
      waitpid($self->{'tcp_chld'}, 0);
      $ret = 0;
    }
    delete $self->{'tcp_chld'};
    $! = $child_errno;
  } else {
    # Otherwise don't waste the resources to fork

    &{ $do_socket }();

    &{ $do_connect_nb }();
  }

  return $ret;
}

sub DESTROY {
  my $self = shift;
  if ($self->{'proto'} eq 'tcp' &&
      $self->{'tcp_chld'}) {
    # Put that choking client out of its misery
    kill "KILL", $self->{'tcp_chld'};
    # Clean off the zombie
    waitpid($self->{'tcp_chld'}, 0);
  }
}

# This writes the given string to the socket and then reads it
# back.  It returns 1 on success, 0 on failure.
sub tcp_echo
{
  my $self = shift;
  my $timeout = shift;
  my $pingstring = shift;

  my $ret = undef;
  my $time = &time();
  my $wrstr = $pingstring;
  my $rdstr = "";

  eval <<'EOM';
    do {
      my $rin = "";
      vec($rin, $self->{"fh"}->fileno(), 1) = 1;

      my $rout = undef;
      if($wrstr) {
        $rout = "";
        vec($rout, $self->{"fh"}->fileno(), 1) = 1;
      }

      if(mselect($rin, $rout, undef, ($time + $timeout) - &time())) {

        if($rout && vec($rout,$self->{"fh"}->fileno(),1)) {
          my $num = syswrite($self->{"fh"}, $wrstr, length $wrstr);
          if($num) {
            # If it was a partial write, update and try again.
            $wrstr = substr($wrstr,$num);
          } else {
            # There was an error.
            $ret = 0;
          }
        }

        if(vec($rin,$self->{"fh"}->fileno(),1)) {
          my $reply;
          if(sysread($self->{"fh"},$reply,length($pingstring)-length($rdstr))) {
            $rdstr .= $reply;
            $ret = 1 if $rdstr eq $pingstring;
          } else {
            # There was an error.
            $ret = 0;
          }
        }

      }
    } until &time() > ($time + $timeout) || defined($ret);
EOM

  return $ret;
}




# Description: Perform a stream ping.  If the tcp connection isn't
# already open, it opens it.  It then sends some data and waits for
# a reply.  It leaves the stream open on exit.

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

  # Open the stream if it's not already open
  if(!defined $self->{"fh"}->fileno()) {
    $self->tcp_connect($ip, $timeout) or return 0;
  }

  croak "tried to switch servers while stream pinging"
    if $self->{"ip"} ne $ip;

  return $self->tcp_echo($timeout, $pingstring);
}

# Description: opens the stream.  You would do this if you want to
# separate the overhead of opening the stream from the first ping.

sub open
{
  my ($self,
      $host,              # Host or IP address
      $timeout            # Seconds after which open times out
      ) = @_;

  my ($ip);               # Packed IP number of the host
  $ip = inet_aton($host);
  $timeout = $self->{"timeout"} unless $timeout;

  if($self->{"proto"} eq "stream") {
    if(defined($self->{"fh"}->fileno())) {
      croak("socket is already open");
    } else {
      $self->tcp_connect($ip, $timeout);
    }
  }
}


# Description:  Perform a udp echo ping.  Construct a message of
# at least the one-byte sequence number and any additional data bytes.
# Send the message out and wait for a message to come back.  If we
# get a message, make sure all of its parts match.  If they do, we are
# done.  Otherwise go back and wait for the message until we run out
# of time.  Return the result of our efforts.

use constant UDP_FLAGS => 0; # Nothing special on send or recv
sub ping_udp
{
  my ($self,
      $ip,                # Packed IP number of the host
      $timeout            # Seconds after which ping times out
      ) = @_;

  my ($saddr,             # sockaddr_in with port and ip
      $ret,               # The return value
      $msg,               # Message to be echoed
      $finish_time,       # Time ping should be finished
      $flush,             # Whether socket needs to be disconnected
      $connect,           # Whether socket needs to be connected
      $done,              # Set to 1 when we are done pinging
      $rbits,             # Read bits, filehandles for reading
      $nfound,            # Number of ready filehandles found
      $from_saddr,        # sockaddr_in of sender
      $from_msg,          # Characters echoed by $host