r68372 - in /branches/upstream/libpoe-component-client-ping-perl: ./ current/ current/CHANGES current/MANIFEST current/META.yml current/Makefile.PL current/Ping.pm current/README current/t/ current/t/01_ping.t
gregoa at users.alioth.debian.org
gregoa at users.alioth.debian.org
Fri Feb 11 16:15:24 UTC 2011
Author: gregoa
Date: Fri Feb 11 16:15:04 2011
New Revision: 68372
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=68372
Log:
[svn-inject] Installing original source of libpoe-component-client-ping-perl (1.04)
Added:
branches/upstream/libpoe-component-client-ping-perl/
branches/upstream/libpoe-component-client-ping-perl/current/
branches/upstream/libpoe-component-client-ping-perl/current/CHANGES
branches/upstream/libpoe-component-client-ping-perl/current/MANIFEST
branches/upstream/libpoe-component-client-ping-perl/current/META.yml
branches/upstream/libpoe-component-client-ping-perl/current/Makefile.PL
branches/upstream/libpoe-component-client-ping-perl/current/Ping.pm
branches/upstream/libpoe-component-client-ping-perl/current/README
branches/upstream/libpoe-component-client-ping-perl/current/t/
branches/upstream/libpoe-component-client-ping-perl/current/t/01_ping.t
Added: branches/upstream/libpoe-component-client-ping-perl/current/CHANGES
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libpoe-component-client-ping-perl/current/CHANGES?rev=68372&op=file
==============================================================================
--- branches/upstream/libpoe-component-client-ping-perl/current/CHANGES (added)
+++ branches/upstream/libpoe-component-client-ping-perl/current/CHANGES Fri Feb 11 16:15:04 2011
@@ -1,0 +1,79 @@
+=========================
+2004-05-31 17:24:07 v1_04
+=========================
+
+ 2004-05-31 17:24:07 by rcaputo; Ping.pm 1.19
+
+ More documentation revisions.
+
+=========================
+2004-05-31 16:34:47 v1_03
+=========================
+
+ 2004-05-31 16:34:47 by rcaputo; Ping.pm 1.18
+
+ Massively revised the documentation. I tried to look something up for
+ Leigh Sharpe, and it was just a mess in there.
+
+ Fixed cases where the user data was not passed through. Mostly during
+ request errors. This is related to Leigh's question on POE's mailing
+ list.
+
+ Bumped the version number up for a CPAN release.
+
+=========================
+2004-03-09 15:22:05 v1_02
+=========================
+
+ 2004-03-09 15:22:05 by rcaputo; Ping.pm 1.17
+
+ Boris Rekhtman reported a "hang" condition when addresses don't
+ resolve. Thanks to his test case, it was tracked down to a leftover
+ socket not being cleaned up if the ping failed early. This commit
+ refactors the socket closure code, fixing his problem and at least
+ one other.
+
+ 2004-02-13 02:23:56 by rcaputo; Ping.pm 1.16
+
+ Don't try to process a packet if recv() fails.
+
+=========================
+2004-01-23 17:26:23 v1_01
+=========================
+
+ 2004-01-23 17:26:23 by rcaputo; Ping.pm 1.15
+
+ Bump the version number up.
+
+ 2004-01-23 17:25:37 by rcaputo; MANIFEST 1.3; Ping.pm 1.14
+
+ Improve sequence number tracking and cleanup.
+
+=========================
+2003-12-07 17:57:58 v1_00
+=========================
+
+ 2003-12-07 17:57:58 by rcaputo; Ping.pm 1.13
+
+ Bump up the version!
+
+ 2003-11-29 06:55:49 by rcaputo; Ping.pm 1.12; t/01_ping.t 1.6
+
+ Applied Edward Henke's patch to correct a typo (and probably a memory
+ leak) in a hash key. Also updated the test program with new ping
+ targets, as the old ones seem to all be down for some reason.
+
+=========================
+2003-09-04 05:57:33 v0_99
+=========================
+
+ 2003-09-04 05:57:33 by rcaputo; Ping.pm 1.11
+
+ "Jim" on Usenet discovered that the component doesn't clean up after
+ a OneReply response. This means the component lingers forever,
+ preventing programs from exiting with OneReply enabled. This commit
+ fixes that.
+
+=============================
+Beginning of Recorded History
+=============================
Added: branches/upstream/libpoe-component-client-ping-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libpoe-component-client-ping-perl/current/MANIFEST?rev=68372&op=file
==============================================================================
--- branches/upstream/libpoe-component-client-ping-perl/current/MANIFEST (added)
+++ branches/upstream/libpoe-component-client-ping-perl/current/MANIFEST Fri Feb 11 16:15:04 2011
@@ -1,0 +1,8 @@
+# $Id: MANIFEST,v 1.3 2004/01/23 17:25:37 rcaputo Exp $
+CHANGES
+MANIFEST
+Makefile.PL
+Ping.pm
+README
+t/01_ping.t
+META.yml Module meta-data (added by MakeMaker)
Added: branches/upstream/libpoe-component-client-ping-perl/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libpoe-component-client-ping-perl/current/META.yml?rev=68372&op=file
==============================================================================
--- branches/upstream/libpoe-component-client-ping-perl/current/META.yml (added)
+++ branches/upstream/libpoe-component-client-ping-perl/current/META.yml Fri Feb 11 16:15:04 2011
@@ -1,0 +1,12 @@
+# http://module-build.sourceforge.net/META-spec.html
+#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
+name: POE-Component-Client-Ping
+version: 1.04
+version_from: Ping.pm
+installdirs: site
+requires:
+ POE: 0.11
+ Time::HiRes: 1.2
+
+distribution_type: module
+generated_by: ExtUtils::MakeMaker version 6.17
Added: branches/upstream/libpoe-component-client-ping-perl/current/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libpoe-component-client-ping-perl/current/Makefile.PL?rev=68372&op=file
==============================================================================
--- branches/upstream/libpoe-component-client-ping-perl/current/Makefile.PL (added)
+++ branches/upstream/libpoe-component-client-ping-perl/current/Makefile.PL Fri Feb 11 16:15:04 2011
@@ -1,0 +1,26 @@
+#!/usr/bin/perl
+# $Id: Makefile.PL,v 1.3 2002/09/10 03:35:21 rcaputo Exp $
+
+use ExtUtils::MakeMaker;
+
+# Touch CHANGES so it exists.
+open(CHANGES, ">>CHANGES") and close CHANGES;
+
+WriteMakefile
+ ( NAME => 'POE::Component::Client::Ping',
+ AUTHOR => 'Rocco Caputo <rcaputo at cpan.org>',
+ ABSTRACT => 'POE component for non-blocking/concurrent ICMP ping.',
+ VERSION_FROM => 'Ping.pm',
+
+ PM => { 'Ping.pm' => '$(INST_LIBDIR)/Ping.pm' },
+ PREREQ_PM => { POE => 0.11,
+ Time::HiRes => 1.20,
+ },
+ dist =>
+ { COMPRESS => 'gzip -9f',
+ SUFFIX => 'gz',
+ PREOP => ( 'cvs-log.perl | ' .
+ 'tee ./$(DISTNAME)-$(VERSION)/CHANGES > ./CHANGES'
+ ),
+ },
+ );
Added: branches/upstream/libpoe-component-client-ping-perl/current/Ping.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libpoe-component-client-ping-perl/current/Ping.pm?rev=68372&op=file
==============================================================================
--- branches/upstream/libpoe-component-client-ping-perl/current/Ping.pm (added)
+++ branches/upstream/libpoe-component-client-ping-perl/current/Ping.pm Fri Feb 11 16:15:04 2011
@@ -1,0 +1,715 @@
+# $Id: Ping.pm,v 1.19 2004/05/31 17:24:07 rcaputo Exp $
+# License and documentation are after __END__.
+
+package POE::Component::Client::Ping;
+
+use warnings;
+use strict;
+
+use Exporter;
+use vars qw(@ISA @EXPORT_OK %EXPORT_TAGS);
+
+ at ISA = qw(Exporter);
+ at EXPORT_OK = qw(
+ REQ_ADDRESS REQ_TIMEOUT REQ_TIME REQ_USER_ARGS RES_ADDRESS
+ RES_ROUNDTRIP RES_TIME
+);
+%EXPORT_TAGS = (
+ const => [
+ qw(
+ REQ_ADDRESS REQ_TIMEOUT REQ_TIME REQ_USER_ARGS RES_ADDRESS
+ RES_ROUNDTRIP RES_TIME
+ )
+ ]
+);
+
+use vars qw($VERSION);
+$VERSION = '1.04';
+
+use Carp qw(croak);
+use Symbol qw(gensym);
+use Socket;
+use Time::HiRes qw(time);
+
+use POE::Session;
+
+sub DEBUG () { 0 } # Enable more information.
+sub DEBUG_SOCKET () { 0 } # Watch the socket open and close.
+sub DEBUG_PBS () { 0 } # Watch ping_by_seq management.
+
+# Spawn a new PoCo::Client::Ping session. This basically is a
+# constructor, but it isn't named "new" because it doesn't create a
+# usable object. Instead, it spawns the object off as a session.
+
+sub spawn {
+ my $type = shift;
+
+ croak "$type requires an even number of parameters" if @_ % 2;
+ my %params = @_;
+
+ croak "$type requires root privilege"
+ if $> and ($^O ne "VMS") and not defined $params{Socket};
+
+ my $alias = delete $params{Alias};
+ $alias = "pinger" unless defined $alias and length $alias;
+
+ my $timeout = delete $params{Timeout};
+ $timeout = 1 unless defined $timeout and $timeout >= 0;
+
+ my $onereply = delete $params{OneReply};
+
+ my $socket = delete $params{Socket};
+
+ croak( "$type doesn't know these parameters: ",
+ join(', ', sort keys %params)
+ ) if scalar keys %params;
+
+ POE::Session->create
+ ( inline_states =>
+ { _start => \&poco_ping_start,
+ ping => \&poco_ping_ping,
+ clear => \&poco_ping_clear,
+ got_pong => \&poco_ping_pong,
+ _default => \&poco_ping_default,
+ },
+ args => [ $alias, $timeout, $socket, $onereply ],
+ );
+
+ undef;
+}
+
+# ping_by_seq structure offsets.
+
+sub PBS_POSTBACK () { 0 };
+sub PBS_SESSION () { 1 };
+sub PBS_ADDRESS () { 2 };
+sub PBS_REQUEST_TIME () { 3 };
+
+# request_packet offsets
+sub REQ_ADDRESS () { 0 };
+sub REQ_TIMEOUT () { 1 };
+sub REQ_TIME () { 2 };
+sub REQ_USER_ARGS () { 3 };
+
+# response_packet offsets
+sub RES_ADDRESS () { 0 };
+sub RES_ROUNDTRIP () { 1 };
+sub RES_TIME () { 2 };
+
+# "Static" variables which will be shared across multiple instances.
+
+my $pid = $$ & 0xFFFF;
+my $master_seq = 0;
+
+# Start the pinger session. Record running stats, and create the
+# socket which will be used to ping.
+
+sub poco_ping_start {
+ my ($kernel, $heap, $alias, $timeout, $socket, $onereply) =
+ @_[KERNEL, HEAP, ARG0..ARG3];
+
+ $heap->{data} = 'Use POE!' x 7; # 56 data bytes :)
+ $heap->{data_size} = length($heap->{data});
+ $heap->{timeout} = $timeout;
+ $heap->{onereply} = $onereply;
+ $heap->{ping_by_seq} = { }; # keyed on sequence number
+ $heap->{addr_to_seq} = { }; # keyed on request address, then sender
+
+ if (defined $socket) {
+ # root is needed for this step too
+ $kernel->select_read($heap->{socket_handle} = $socket, 'got_pong');
+ $heap->{keep_socket} = 1;
+ } else {
+ $heap->{keep_socket} = 0;
+ }
+
+ $kernel->alias_set($alias);
+}
+
+# ICMP echo constants. Types, structures, and fields. Cribbed
+# mercilessly from Net::Ping.
+
+sub ICMP_ECHOREPLY () { 0 }
+sub ICMP_ECHO () { 8 }
+sub ICMP_STRUCT () { 'C2 S3 A' }
+sub ICMP_SUBCODE () { 0 }
+sub ICMP_FLAGS () { 0 }
+sub ICMP_PORT () { 0 }
+
+# Request a ping. This code borrows heavily from Net::Ping.
+
+sub poco_ping_ping {
+ my ($kernel, $heap, $sender, $event, $address, $timeout) =
+ @_[KERNEL, HEAP, SENDER, ARG0, ARG1, ARG2];
+
+ # No current pings. Open a socket.
+ unless (exists $heap->{socket_handle}) {
+ DEBUG_SOCKET and warn "opening a raw socket for icmp";
+
+ my $protocol = (getprotobyname('icmp'))[2]
+ or die "can't get icmp protocol by name: $!";
+
+ my $socket = gensym();
+ socket($socket, PF_INET, SOCK_RAW, $protocol)
+ or die "can't create icmp socket: $!";
+
+ $kernel->select_read($heap->{socket_handle} = $socket, 'got_pong');
+ }
+
+ # Get the timeout, or default to the one set for the component.
+ $timeout = $heap->{timeout} unless defined $timeout and $timeout > 0;
+
+ # Find an unused sequence number.
+ while (1) {
+ $master_seq = ($master_seq + 1) & 0xFFFF;
+ last unless exists $heap->{ping_by_seq}->{$master_seq};
+ }
+
+ my $checksum = 0;
+
+ # Build the message without a checksum.
+ my $msg = pack(
+ ICMP_STRUCT . $heap->{data_size},
+ ICMP_ECHO, ICMP_SUBCODE, $checksum, $pid, $master_seq, $heap->{data}
+ );
+
+ ### Begin checksum calculation section.
+
+ # Sum up short integers in the packet.
+ my $shorts = int(length($msg) / 2);
+ foreach my $short (unpack "S$shorts", $msg) {
+ $checksum += $short;
+ }
+
+ # If there's an odd byte, add that in as well.
+ $checksum += ord(substr($msg, -1)) if length($msg) % 2;
+
+ # Fold the high short into the low one twice, and then complement.
+ $checksum = ($checksum >> 16) + ($checksum & 0xFFFF);
+ $checksum = ~( ($checksum >> 16) + $checksum) & 0xFFFF;
+
+ ### Cease checksum calculation section.
+
+ # Rebuild the message with the checksum this time.
+ $msg = pack(
+ ICMP_STRUCT . $heap->{data_size},
+ ICMP_ECHO, ICMP_SUBCODE, $checksum, $pid, $master_seq, $heap->{data}
+ );
+
+ # Record the message's length. This is constant, but we do it here
+ # anyway. It's also used to flag when we start requesting replies.
+ $heap->{message_length} = length($msg);
+
+ # Record information about the ping request.
+ my @user_args = ();
+ if (ref($event) eq "ARRAY") {
+ @user_args = @{ $event };
+ $event = shift @user_args;
+ }
+
+ # Build an address to send the ping at.
+ my $usable_address = (
+ (length($address) == 4)
+ ? $address
+ : inet_aton($address)
+ );
+
+ # Return failure if an address was not resolvable. This simulates
+ # the postback behavior.
+ unless (defined $usable_address) {
+ $kernel->post(
+ $sender, $event,
+ [ $address, # REQ_ADDRESS
+ $timeout, # REQ_TIMEOUT
+ time(), # REQ_TIME
+ @user_args, # REQ_USER_ARGS
+ ],
+ [ undef, # RES_ADDRESS
+ undef, # RES_ROUNDTRIP
+ time(), # RES_TIME
+ ],
+ );
+ _check_for_close($kernel, $heap);
+ return;
+ }
+
+ my $socket_address = pack_sockaddr_in(ICMP_PORT, $usable_address);
+
+ # Send the packet. If send() fails, then we bail with an error.
+ unless (send($heap->{socket_handle}, $msg, ICMP_FLAGS, $socket_address)) {
+ $kernel->post(
+ $sender, $event,
+ [ $address, # REQ_ADDRESS
+ $timeout, # REQ_TIMEOUT
+ time(), # REQ_TIME
+ @user_args, # REQ_USER_ARGS
+ ],
+ [ undef, # RES_ADDRESS
+ undef, # RES_ROUNDTRIP
+ time(), # RES_TIME
+ ],
+ );
+ _check_for_close($kernel, $heap);
+ return;
+ }
+
+ # Set a timeout based on the sequence number.
+ $kernel->delay( $master_seq => $timeout );
+
+ DEBUG_PBS and warn "recording ping_by_seq($master_seq)";
+ $heap->{ping_by_seq}->{$master_seq} = [
+ # PBS_POSTBACK
+ $sender->postback(
+ $event,
+ $address, # REQ_ADDRESS
+ $timeout, # REQ_TIMEOUT
+ time(), # REQ_TIME
+ @user_args, # REQ_USER_ARGS
+ ),
+ "$sender", # PBS_SESSION (stringified to weaken reference)
+ $address, # PBS_ADDRESS
+ time() # PBS_REQUEST_TIME
+ ];
+
+ # Duplicate pings? Forcibly time out the previous one.
+ if (exists $heap->{addr_to_seq}->{$sender}->{$address}) {
+ my $now = time();
+ my $old_seq = delete $heap->{addr_to_seq}->{$sender}->{$address};
+ my $old_info = delete $heap->{ping_by_seq}->{$old_seq};
+ $old_info->[PBS_POSTBACK]->( undef, undef, $now );
+ }
+
+ $heap->{addr_to_seq}->{$sender}->{$address} = $master_seq;
+}
+
+# Clear a ping postback by address. The sender+address pair are a
+# unique ID into the pinger's data.
+
+sub poco_ping_clear {
+ my ($kernel, $heap, $sender, $address) = @_[KERNEL, HEAP, SENDER, ARG0];
+
+ # Is the sender still waiting for anything?
+ return unless exists $heap->{addr_to_seq}->{$sender};
+
+ # Try to clear a single ping if an address was specified.
+ if (defined $address) {
+
+ # Don't bother if we don't have it.
+ return unless exists $heap->{addr_to_seq}->{$sender}->{$address};
+
+ # Stop mapping the sender+address pair to that sequence number.
+ my $seq = delete $heap->{addr_to_seq}->{$sender}->{$address};
+
+ # Stop tracking the sender if that was the last address.
+ delete $heap->{addr_to_seq}->{$sender}
+ unless scalar(keys %{$heap->{addr_to_seq}->{$sender}});
+
+ # Discard the postback for the discarded sequence number.
+ DEBUG_PBS and warn "removing ping_by_seq($seq)";
+ delete $heap->{ping_by_seq}->{$seq};
+ $kernel->delay($seq);
+ }
+
+ # No address was specified. Clear all the pings for this session.
+ else {
+ # First discard all the ping records.
+ foreach my $seq (values %{$heap->{addr_to_seq}->{$sender}}) {
+ DEBUG_PBS and warn "removing ping_by_seq($seq)";
+ delete $heap->{ping_by_seq}->{$seq};
+ $kernel->delay($seq);
+ }
+
+ # Now clear all the postbacks for the sender.
+ delete $heap->{addr_to_seq}->{$sender};
+ }
+
+ _check_for_close($kernel, $heap);
+}
+
+# XXX - NOT A POE EVENT HANDLER
+# Check to see if no more pings are waiting. Close the socket if so.
+sub _check_for_close {
+ my ($kernel, $heap) = @_;
+ unless (scalar(keys %{$heap->{ping_by_seq}}) || $heap->{keep_socket}) {
+ DEBUG_SOCKET and warn "closing the raw icmp socket";
+ $kernel->select_read( delete $heap->{socket_handle} );
+ }
+}
+
+# Something has arrived. Try to match it against something being
+# waited for.
+
+sub poco_ping_pong {
+ my ($kernel, $heap, $socket) = @_[KERNEL, HEAP, ARG0];
+
+ # Record the receive time for possible use later.
+ my $now = time();
+
+ # Receive a message on the ICMP port.
+ my $recv_message = '';
+ my $from_saddr = recv($socket, $recv_message, 1500, ICMP_FLAGS);
+ return unless $from_saddr;
+
+ # We haven't yet sent a message, so don't bother with whatever we've
+ # received.
+ return unless defined $heap->{message_length};
+
+ # Unpack the packet's sender address.
+ my ($from_port, $from_ip) = unpack_sockaddr_in($from_saddr);
+
+ # Unpack the packet itself.
+ my (
+ $from_type, $from_subcode,
+ $from_checksum, $from_pid, $from_seq, $from_message
+ ) = unpack(
+ ICMP_STRUCT . $heap->{data_size},
+ substr($recv_message, -$heap->{message_length})
+ );
+
+ DEBUG and do {
+ warn ",----- packet from ", inet_ntoa($from_ip), ", port $from_port\n";
+ warn "| type = $from_type / subtype = $from_subcode\n";
+ warn "| checksum = $from_checksum, pid = $from_pid, seq = $from_seq\n";
+ warn "| message: $from_message\n";
+ warn "`------------------------------------------------------------\n";
+ };
+
+ # Not an ICMP echo reply. Move along.
+ return unless $from_type == ICMP_ECHOREPLY;
+
+ DEBUG and warn "it's an ICMP echo reply";
+
+ # Not from this process. Move along.
+ return unless $from_pid == $pid;
+
+ DEBUG and warn "it's from this process ($pid)";
+
+ # Not waiting for a response with that sequence number. Move along.
+ return unless exists $heap->{ping_by_seq}->{$from_seq};
+
+ DEBUG and warn "it's one we're waiting for ($from_seq)";
+
+ # This is the response we're looking for. Calculate the round trip
+ # time, and map it to a postback.
+ my $trip_time = $now - $heap->{ping_by_seq}->{$from_seq}->[PBS_REQUEST_TIME];
+ $heap->{ping_by_seq}->{$from_seq}->[PBS_POSTBACK]->(
+ inet_ntoa($from_ip), $trip_time, $now
+ );
+
+ # It's a single-reply ping. Clean up after it.
+ # TODO - This is a lot like the cleanup in poco_ping_default().
+ # Consider combining both if it makes sense.
+ if ($heap->{onereply}) {
+ # Delete the ping information. Cache a copy for other cleanup.
+ DEBUG_PBS and warn "removing ping_by_seq($from_seq)";
+ my $ping_info = delete $heap->{ping_by_seq}->{$from_seq};
+ $kernel->delay($from_seq);
+
+ # Stop mapping the session+address to this sequence number.
+ delete(
+ $heap->{addr_to_seq}->{
+ $ping_info->[PBS_SESSION]
+ }->{$ping_info->[PBS_ADDRESS]}
+ );
+
+ # Stop tracking the session if that was the last address.
+ delete $heap->{addr_to_seq}->{$ping_info->[PBS_SESSION]}
+ unless scalar(keys %{$heap->{addr_to_seq}->{$ping_info->[PBS_SESSION]}});
+
+ _check_for_close($kernel, $heap);
+ }
+}
+
+# Default's used to catch ping timeouts, which are named after the
+# packed socket addresses being pinged. We always send the timeout so
+# the other session knows that a ping period has ended.
+
+sub poco_ping_default {
+ my ($kernel, $heap, $seq) = @_[KERNEL, HEAP, ARG0];
+
+ # Record the receive time for possible use later.
+ my $now = time();
+
+ # Are we waiting for this sequence number? We should be!
+ if (exists $heap->{ping_by_seq}->{$seq}) {
+
+ # Delete the ping information, but cache a copy for other work.
+ DEBUG_PBS and warn "removing ping_by_seq($seq)";
+ my $ping_info = delete $heap->{ping_by_seq}->{$seq};
+
+ # Post a timer tick back to the session. This marks the end of
+ # the request/response transaction.
+ $ping_info->[PBS_POSTBACK]->( undef, undef, $now );
+
+ # Stop mapping the session+address to this sequence number.
+ delete(
+ $heap->{addr_to_seq}->{
+ $ping_info->[PBS_SESSION]
+ }->{$ping_info->[PBS_ADDRESS]}
+ );
+
+ # Stop tracking the session if that was the last address.
+ delete $heap->{addr_to_seq}->{$ping_info->[PBS_SESSION]}
+ unless scalar(keys %{$heap->{addr_to_seq}->{$ping_info->[PBS_SESSION]}});
+
+ _check_for_close($kernel, $heap);
+
+ return 1;
+ }
+ else {
+ warn "this shouldn't technically be displayed ($seq)"
+ if DEBUG and $seq =~ /^\d+$/;
+
+ # Let unhandled signals pass through so we do not block SIGINT, etc.
+ return 0;
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+POE::Component::Client::Ping - a non-blocking ICMP ping client
+
+=head1 SYNOPSIS
+
+ use POE qw(Component::Client::Ping);
+
+ POE::Component::Client::Ping->spawn(
+ Alias => "pingthing", # defaults to "pinger"
+ Timeout => 10, # defaults to 1 second
+ OneReply => 1 # defaults to disabled
+ );
+
+ sub some_event_handler {
+ $kernel->post(
+ "pingthing", # Post the request to the "pingthing" component.
+ "ping", # Ask it to "ping" an address.
+ "pong", # Have it post an answer as a "pong" event.
+ $address, # This is the address we want to ping.
+ $timeout, # Optional timeout. It overrides the default.
+ );
+ }
+
+ # This is the sub which is called when the session receives a "pong"
+ # event. It handles responses from the Ping component.
+ sub got_pong {
+ my ($request, $response) = @_[ARG0, ARG1];
+
+ my ($req_address, $req_timeout, $req_time) = @$request;
+ my ($resp_address, $roundtrip_time, $resp_time) = @$response;
+
+ # The response address is defined if this is a response.
+ if (defined $resp_address) {
+ printf(
+ "ping to %-15.15s at %10d. pong from %-15.15s in %6.3f s\n",
+ $req_address, $req_time,
+ $resp_address, $roundtrip_time,
+ );
+ return;
+ }
+
+ # Otherwise the timeout period has ended.
+ printf(
+ "ping to %-15.15s is done.\n", $req_address,
+ );
+ }
+
+ or
+
+ use POE::Component::Client::Ping ":const";
+
+ # Post an array ref as the callback to get data back to you
+ $kernel->post("pinger", "ping", [ "pong", $user_data ]);
+
+ # use the REQ_USER_ARGS constant to get to your data
+ sub got_pong {
+ my ($request, $response) = @_[ARG0, ARG1];
+ my $user_data = $request->[REQ_USER_ARGS];
+ ...;
+ }
+
+=head1 DESCRIPTION
+
+POE::Component::Client::Ping is non-blocking ICMP ping client. It
+lets several other sessions ping through it in parallel, and it lets
+them continue doing other things while they wait for responses.
+
+Ping client components are not proper objects. Instead of being
+created, as most objects are, they are "spawned" as separate sessions.
+To avoid confusion (and hopefully not cause other confusion), they
+must be spawned with a C<spawn> method, not created anew with a C<new>
+one.
+
+PoCo::Client::Ping's C<spawn> method takes a few named parameters:
+
+=over 2
+
+=item Alias => $session_alias
+
+C<Alias> sets the component's alias. It is the target of post()
+calls. See the synopsis. The alias defaults to "pinger".
+
+=item Socket => $raw_socket
+
+C<Socket> allows developers to open an existing raw socket rather
+than letting the component attempt opening one itself. If omitted,
+the component will create its own raw socket.
+
+This is useful for people who would rather not perform a security
+audit on POE, since it allows them to create a raw socket in their own
+code and then run POE at reduced privileges.
+
+=item Timeout => $ping_timeout
+
+C<Timeout> sets the default amount of time a Ping component will wait
+for an ICMP echo reply, in seconds. It is 1 by default. It's
+possible and meaningful to set the timeout to a fractional number of
+seconds.
+
+This default timeout is only used for ping requests that don't include
+their own timeouts.
+
+=item OneReply => 0|1
+
+Set C<OneReply> to prevent the Ping component from waiting the full
+timeout period for replies. Normally the ICMP protocol allows for
+multiple replies to a single request, so it's proper to wait for late
+responses. This option disables the wait, ending the ping transaction
+at the first response. Any subsequent responses will be silently
+ignored.
+
+C<OneReply> is disabled by default, and a single successful request
+will generate at least two responses. The first response is a
+successful ICMP ECHO REPLY event. The second is an undefined response
+event, signifying that the timeout period has ended.
+
+A ping request will generate exactly one reply when C<OneReply> is
+enabled. This reply will represent either the first ICMP ECHO REPLY
+to arrive or that the timeout period has ended.
+
+=back
+
+Sessions communicate asynchronously with the Client::Ping component.
+They post ping requests to it, and they receive pong events back.
+
+Requests are posted to the component's "ping" handler. They include
+the name of an event to post back, an address to ping, and an optional
+amount of time to wait for responses. The address may be a numeric
+dotted quad, a packed inet_aton address, or a host name. Host names
+are not recommended: they must be looked up for every ping request,
+and DNS lookups can be very slow. The optional timeout overrides the
+one set when C<spawn> is called.
+
+Ping responses come with two array references:
+
+ my ($request, $response) = @_[ARG0, ARG1];
+
+C<$request> contains information about the original request:
+
+ my (
+ $req_address, $req_timeout, $req_time, $req_user_args,
+ ) = @$request;
+
+=over 2
+
+=item C<$req_address>
+
+This is the original request address. It matches the address posted
+along with the original "ping" request.
+
+It is useful along with C<$req_user_args> for pairing requests with
+their corresponding responses.
+
+=item C<$req_timeout>
+
+This is the original request timeout. It's either the one passed with
+the "ping" request or the default timeout set with C<spawn>.
+
+=item C<$req_time>
+
+This is the time that the "ping" event was received by the Ping
+component. It is a real number based on the current system's time()
+epoch.
+
+=item C<$req_user_args>
+
+This is a scalar containing arbitrary data that can be sent along with
+a request. It's often used to provide continuity between requests and
+their responses. C<$req_user_args> may contain a reference to some
+larger data structure.
+
+To use it, replace the response event with an array reference in the
+original request. The array reference should contain two items: the
+actual response event and a scalar with the context data the program
+needs back. See the SYNOPSIS for an example.
+
+=back
+
+C<$response> contains information about the ICMP ping response. There
+may be multiple responses for a single request.
+
+ my ($response_address, $roundtrip_time, $reply_time) = @$response;
+
+=over 2
+
+=item C<$response_address>
+
+This is the address that responded to the ICMP echo request. It may
+be different than C<$request_address>, especially if the request was
+sent to a broadcast address.
+
+C<$response_address> will be undefined if C<$request_timeout> seconds
+have elapsed. This marks the end of responses for a given request.
+Programs can assume that no more responses will be sent for the
+request address. They may use this marker to initiate another ping
+request.
+
+=item C<$roundtrip_time>
+
+This is the number of seconds that elapsed between the ICMP echo
+request's transmission and its corresponding response's receipt. It's
+a real number.
+
+=item C<$reply_time>
+
+This is the time when the ICMP echo response was received. It is a
+real number based on the current system's time() epoch.
+
+=back
+
+If the ":const" tagset is imported the following constants will be
+exported:
+
+REQ_ADDRESS, REQ_TIMEOUT, REQ_TIME
+REQ_USER_ARGS, RES_ADDRESS, RES_ROUNDTRIP, RES_TIME
+
+=head1 SEE ALSO
+
+This component's ICMP ping code was lifted from Net::Ping, which is an
+excellent module when you only need to ping one host at a time.
+
+See POE, of course, which includes a lot of documentation about how
+POE works.
+
+Also see the test program, t/01_ping.t, in the component's
+distribution.
+
+=head1 BUGS
+
+None currently known.
+
+=head1 AUTHOR & COPYRIGHTS
+
+POE::Component::Client::Ping is Copyright 1999-2004 by Rocco Caputo.
+All rights are reserved. POE::Component::Client::Ping is free
+software; you may redistribute it and/or modify it under the same
+terms as Perl itself.
+
+Rocco may be contacted by e-mail via <rcaputo at cpan.org>.
+
+You can learn more about POE at <http://poe.perl.org/>.
+
+=cut
Added: branches/upstream/libpoe-component-client-ping-perl/current/README
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libpoe-component-client-ping-perl/current/README?rev=68372&op=file
==============================================================================
--- branches/upstream/libpoe-component-client-ping-perl/current/README (added)
+++ branches/upstream/libpoe-component-client-ping-perl/current/README Fri Feb 11 16:15:04 2011
@@ -1,0 +1,68 @@
+$Id: README,v 1.2 2001/05/29 16:51:39 rcaputo Exp $
+
+--------
+Abstract
+--------
+
+POE::Component::Client::Ping is an asynchronous, event driven client
+for ICMP ping. It accepts events containing the specifics of ICMP
+ping requests, and it returns events carrying the results of those
+pings.
+
+------------
+Requirements
+------------
+
+This module requires POE. It also requires root privilege, or your
+operating system's equivalent, so that it can open a socket for ICMP
+ping. Knowing what this means, how to achieve it, and the potential
+hazards of doing so are left as exercises for the reader.
+
+------------------
+Basic Installation
+------------------
+
+POE::Component::Client::Ping may be installed through the CPAN shell
+in the usual CPAN shell manner. This typically is:
+
+ $ perl -MCPAN -e 'intstall POE::Component::Client::Ping'
+
+You can also read this README from the CPAN shell:
+
+ $ perl -MCPAN -e shell
+ cpan> readme POE::Component::Client::Ping
+
+And you can install the component from the CPAN prompt as well:
+
+ cpan> install POE::Component::Client::Ping
+
+-------------------
+Manual Installation
+-------------------
+
+POE::Component::Client::Ping can also be installed manually.
+<ftp://ftp.cpan.org/pub/CPAN/authors/id/R/RC/RCAPUTO/> or a similarly
+named directory at your favorite CPAN mirror should hold the latest
+version.
+
+Downloading and unpacking the distribution are left as exercises for
+the reader. To build and test it:
+
+ perl Makefile.PL
+ make test
+
+The test program, t/01_ping.t, makes an excellent sample program. In
+fact, it was adapted from the sample program used to debug this
+component. If you would like to see more details about the test's
+operation, edit t/01_ping.t and set the DEBUG constant to any value
+Perl considers "true".
+
+When you're ready to install the component:
+
+ make install
+
+It should now be ready to use.
+
+Thanks for reading!
+
+-- Rocco Caputo / troc at netrus.net / poe.perl.org / poe.sourceforge.net
Added: branches/upstream/libpoe-component-client-ping-perl/current/t/01_ping.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libpoe-component-client-ping-perl/current/t/01_ping.t?rev=68372&op=file
==============================================================================
--- branches/upstream/libpoe-component-client-ping-perl/current/t/01_ping.t (added)
+++ branches/upstream/libpoe-component-client-ping-perl/current/t/01_ping.t Fri Feb 11 16:15:04 2011
@@ -1,0 +1,135 @@
+#!/usr/bin/perl -w
+# $Id: 01_ping.t,v 1.6 2003/11/29 06:55:49 rcaputo Exp $
+
+use strict;
+
+use lib '/home/troc/perl/poe';
+
+BEGIN {
+ $| = 1;
+ if ($> and ($^O ne 'VMS')) {
+ print "1..0 # skipped: ICMP ping requires root privilege\n";
+ exit 0;
+ }
+};
+
+sub POE::Kernel::ASSERT_DEFAULT () { 1 }
+use POE qw(Component::Client::Ping);
+
+print "1..4\n";
+
+sub PING_TIMEOUT () { 5 }; # seconds between pings
+sub PING_COUNT () { 1 }; # ping repetitions
+sub DEBUG () { 0 }; # display more information
+
+#------------------------------------------------------------------------------
+# A bunch of addresses to ping.
+
+my @addresses = qw(
+ 127.0.0.1 209.34.66.60 216.127.84.31 216.132.181.250 216.132.181.251
+ 64.106.159.160 64.127.105.9 64.235.246.143 64.38.255.150
+ 66.207.163.5 66.33.204.143
+);
+
+#------------------------------------------------------------------------------
+# This session uses the ping component to resolve things.
+
+sub client_start {
+ my ($kernel, $session, $heap) = @_[KERNEL, SESSION, HEAP];
+
+ DEBUG and warn($session->ID, ": starting pinger client session...\n");
+
+ # Set up recording.
+ $heap->{requests} = 0;
+ $heap->{answers} = 0;
+ $heap->{dones} = 0;
+ $heap->{ping_counts} = { };
+
+ # Start pinging.
+ foreach my $address (@addresses) {
+ $heap->{ping_counts}->{$address} = 0;
+ $kernel->call( $session, ping => $address );
+ }
+}
+
+sub client_send_ping {
+ my ($kernel, $session, $heap, $address) = @_[KERNEL, SESSION, HEAP, ARG0];
+
+ DEBUG and warn( $session->ID, ": pinging $address...\n" );
+
+ $heap->{requests}++;
+ $heap->{ping_counts}->{$address}++;
+ $kernel->post( 'pinger', # Post the request to the 'pinger'.
+ 'ping', # Ask it to 'ping' an address.
+ 'pong', # Have it post an answer to my 'pong' state.
+ $address, # This is the address we want it to ping.
+ PING_TIMEOUT # This is the optional time to wait.
+ );
+}
+
+sub client_got_pong {
+ my ($kernel, $session, $heap, $request_packet, $response_packet) =
+ @_[KERNEL, SESSION, HEAP, ARG0, ARG1];
+
+ my ($request_address, $request_timeout, $request_time) = @{$request_packet};
+ my ($response_address, $roundtrip_time, $reply_time) = @{$response_packet};
+
+ if (defined $response_address) {
+ DEBUG and warn
+ sprintf( "%d: ping to %-15.15s at %10d. pong from %-15.15s in %6.3f s\n",
+ $session->ID,
+ $request_address, $request_time,
+ $response_address, $roundtrip_time
+ );
+
+ $heap->{answers}++ if $roundtrip_time <= $request_timeout;
+ }
+ else {
+ DEBUG and warn( $session->ID, ": time's up for $request_address...\n" );
+
+ $kernel->yield(ping => $request_address)
+ if $heap->{ping_counts}->{$request_address} < PING_COUNT;
+
+ $heap->{dones}++;
+ }
+}
+
+sub client_stop {
+ my ($session, $heap) = @_[SESSION, HEAP];
+ DEBUG and warn( $session->ID, ": pinger client session stopped...\n" );
+
+ print 'not ' unless ( $heap->{requests} == $heap->{dones} and
+ $heap->{answers}
+ );
+ print 'ok ', ($session->ID() - 1), "\n";
+}
+
+#------------------------------------------------------------------------------
+
+# Create a pinger component.
+POE::Component::Client::Ping->spawn
+ ( Alias => 'pinger', # This is the name it'll be known by.
+ Timeout => PING_TIMEOUT, # This is how long it waits for echo replies.
+ );
+
+# Create two sessions that will use the pinger. This tests
+# concurrency against the same addresses.
+for (my $session_index = 0; $session_index < 2; $session_index++) {
+ POE::Session->create
+ ( inline_states =>
+ { _start => \&client_start,
+ _stop => \&client_stop,
+ pong => \&client_got_pong,
+ ping => \&client_send_ping,
+ }
+ );
+}
+
+print "ok 1\n";
+
+# Run it all until done.
+$poe_kernel->run();
+
+print "ok 4\n";
+
+exit;
More information about the Pkg-perl-cvs-commits
mailing list