Fwd: CPAN Upload: JPRIT/Event-tcp-0.14.tar.gz

[email protected] (Joshua N Pritikin)
Newsgroups perl.loop
Message-ID <[email protected]> 
----- Forwarded message from [email protected] -----

Date: Wed, 23 Feb 2000 19:44:17 +0100
Subject: CPAN Upload: JPRIT/Event-tcp-0.14.tar.gz
From: [email protected]
To: [email protected],
    [email protected]

The uploaded file

    Event-tcp-0.14.tar.gz

has entered CPAN as

  file: $CPAN/authors/id/JPRIT/Event-tcp-0.14.tar.gz
  size: 7083 bytes
   md5: a46a86e2f5448672a091f4ad706e5b73

No action is required on your part
Request entered by: JPRIT (Joshua N. Pritikin)
Request entered on: Wed, 23 Feb 2000 18:43:35 GMT
Request completed:  Wed, 23 Feb 2000 18:44:17 GMT

	Virtually Yours,
	Id: paused,v 1.68 1999/10/22 14:39:12 k Exp k 


----- End forwarded message -----

# This is a patch for Event-tcp-0.13 to update it to Event-tcp-0.14
# 
# To apply this patch:
# STEP 1: Chdir to the source directory.
# STEP 2: Run the 'applypatch' program with this patch file as input.
#
# If you do not have 'applypatch', it is part of the 'makepatch' package
# that you can fetch from the Comprehensive Perl Archive Network:
# http://www.perl.com/CPAN/authors/Johan_Vromans/makepatch-x.y.tar.gz
# In the above URL, 'x' should be 2 or higher.
#
# To apply this patch without the use of 'applypatch':
# STEP 1: Chdir to the source directory.
# STEP 2: Run the 'patch' program with this file as input.
#
#### End of Preamble ####

#### Patch data follows ####
gdiff -up '/usr/tmp/mp13568.d/old/Event-tcp-0.13/ChangeLog' '/usr/tmp/mp13568.d/new/Event-tcp-0.14/ChangeLog'
Index: ./ChangeLog
--- ./ChangeLog	Tue Feb  1 11:51:13 2000
+++ ./ChangeLog	Wed Feb 23 13:38:08 2000
@@ -1,3 +1,13 @@
+2000-02-23  Joshua Pritikin  <[email protected]>
+
+	* Release 0.14.
+
+2000-02-08  Joshua Pritikin  <[email protected]>
+
+	* Fix potential timing problems with join.t.
+
+	* Added tons of diagnostics to track down Event 0.65 bug.
+
 2000-02-01  Joshua Pritikin  <[email protected]>
 
 	* Release 0.13.
gdiff -up '/usr/tmp/mp13568.d/old/Event-tcp-0.13/lib/Event/tcpsession.pm' '/usr/tmp/mp13568.d/new/Event-tcp-0.14/lib/Event/tcpsession.pm'
Index: ./lib/Event/tcpsession.pm
--- ./lib/Event/tcpsession.pm	Tue Feb  1 11:51:06 2000
+++ ./lib/Event/tcpsession.pm	Wed Feb 23 13:38:22 2000
@@ -10,7 +10,10 @@ use Event::Watcher qw(R W T);
 require Event::io;
 use base 'Event::io';
 use vars qw($VERSION);
-$VERSION = '0.13';
+$VERSION = '0.14';
+
+use constant DEBUG_SHOW_RPCS => 0;
+use constant DEBUG_BYTES => 0;
 
 use constant PROTOCOL_VERSION => 2;
 use constant RECONNECT_TM => 3;
@@ -82,7 +85,6 @@ sub fd {
 	    if (!defined $fd) {
 		# This is a special case for regression testing.
 		# Who knows, maybe it is generally useful too.
-		$o->stop;
 		close $o->fd;
 		$o->SUPER::fd(undef)
 	    } else {
@@ -156,7 +158,6 @@ sub disconnect {
 	return 1;
     }
     $o->{status_cb}->($o, 'disconnect', $why);
-    $o->fd(undef);
     $o->connect_to_server;
 }
 
@@ -169,12 +170,12 @@ sub connect_to_server {
     if (!connect($fd, sockaddr_in($o->{port}, $o->{iaddr}))) {
 	$o->{status_cb}->($o, 'connect', $!);
 	$o->timeout(RECONNECT_TM);
-	$o->start;
 	$o->cb([$o,'connect_to_server']);
+	$o->start;
 	return
     }
-    $o->{status_cb}->($o, 'connect');
     $o->fd($fd);
+    $o->{status_cb}->($o, 'connect');
     $o->reconnected;
     1
 }
@@ -183,7 +184,6 @@ sub reconnected {
     my ($o) = @_;
 
     $o->timeout(undef);
-    $o->start;
     delete $o->{pend};
     delete $o->{peer_version};
     delete $o->{peer_api};
@@ -201,12 +201,13 @@ sub reconnected {
     # reload pending transactions
     # (anything not requiring acknowledgement gets/got ignored)
     while (my ($tx,$i) = each %{$o->{pend}}) {
-	warn "pend $i->[0]{name}";
+	# warn "pend $i->[0]{name}";
 	append_obuf($o, $tx, $i->[2]);
     }
 
     $o->poll(R|W);
     $o->cb([$o,'service']);
+    $o->start;
 }
 
 #########################################################################
@@ -215,8 +216,6 @@ sub append_obuf {    # function call
     my ($o, $tx, $m) = @_;
     # length is inclusive
     my $mlen = length $m;
-#    confess "$mlen > 32000"
-#	if $mlen > 32000;
     $o->{obuf} .= pack(HEADER_FORMAT, 6+$mlen, $tx) . $m;
 
     $o->poll($o->poll | W);
@@ -249,12 +248,10 @@ sub unpack_args {
 sub service {
     my ($o, $e) = @_;
     my $w = $e->w;
-    if ($e->got & T) {
-	return if $o->disconnect("inactivity")
-    }
-    if (!defined $w->fd) {
-	return if $o->disconnect("fd closed")
-    }
+    return $o->disconnect("inactivity")
+	if $e->got & T;
+    return $o->disconnect("fd closed")
+	if !defined $w->fd;
     if ($e->got & R) {
 	my $buf = $o->{ibuf};
 	while (1) {
@@ -263,10 +260,13 @@ sub service {
 	    last if $!{EAGAIN};
 	    return $o->disconnect("sysread ret=$ret, $!");
 	}
+	#warn "$$:R:".unpack('h*', $buf).":";
 	# decode $buf
 	if (!exists $o->{peer_version} and length $buf >= 2) {
 	    # check PROTOCOL_VERSION ...
 	    $o->{peer_version} = unpack 'n', substr($buf, 0, 2);
+	    warn "$$:peer_version=$o->{peer_version}"
+		if DEBUG_SHOW_RPCS;
 	    $buf = substr $buf, 2;
 	    $o->disconnect("peer version mismatch $o->{peer_version} != ".
 			   PROTOCOL_VERSION)
@@ -288,7 +288,10 @@ sub service {
 		    next
 		}
 		# EVAL
-		$api->{code}->($o, unpack_args($api->{req}, $m));
+		my @args = unpack_args($api->{req}, $m);
+		warn "$$:Run($opid)(".join(', ', @args).")"
+		    if DEBUG_SHOW_RPCS;
+		$api->{code}->($o, @args);
 
 	    } elsif ($tx < RESERVED_IDS) {
 		if ($tx == APIMAP_ID) {
@@ -304,7 +307,8 @@ sub service {
 			    warn "got strange API spec: ".join(', ',@spec);
 			}
 		    }
-		    # warn "got ".(0+@api)." APIs";
+		    warn "$$: ".(0+@api)." APIs"
+			if DEBUG_SHOW_RPCS;
 		    $o->{peer_api} = \@api;
 		    my %peer_opname;
 		    for (my $x=0; $x < @api; $x++) {
@@ -328,8 +332,13 @@ sub service {
 			next
 		    }
 		    # EVAL
-		    my @ret = $api->{code}->($o, unpack_args($api->{req}, $m));
-		    # what if exception?
+		    my @args = unpack_args($api->{req}, $m);
+		    warn "$$:Run($opid)(".join(", ", @args).") returning..."
+			if DEBUG_SHOW_RPCS;
+		    my @ret = $api->{code}->($o, @args);
+		    # what if exception? XXX
+		    warn "$$:Return($opid)(".join(", ", @ret).")"
+			if DEBUG_SHOW_RPCS;
 		    my $packed_ret = pack_args($api->{reply}, @ret);
 		    warn("'$api->{name}' returned (".join(', ',@ret).
 			 " yet doesn't have a reply pack template")
@@ -345,7 +354,10 @@ sub service {
 		    my ($api,$cb) = @$pend;
 		    my $opid = unpack 'n', $m; # can double check opid XXX
 		    # EVAL
-		    $cb->($o, unpack_args($api->{reply}, substr($m, 2)));
+		    my @args= unpack_args($api->{reply}, substr($m, 2));
+		    warn "$$:RunReply($opid)(".join(", ", @args).")"
+			if DEBUG_SHOW_RPCS;
+		    $cb->($o, @args);
 		}
 	    }
 	}
@@ -360,6 +372,8 @@ sub service {
 	    return $o->disconnect("syswrite: $!")
 	}
 	if ($sent) {
+	    warn "$$:W:".unpack('h*', substr($buf, 0, $sent)).":"
+		if DEBUG_BYTES;
 	    $buf = substr $buf, $sent;
 	    $o->{obuf} = $buf;
 	}
@@ -378,7 +392,8 @@ sub rpc {
     my $o = shift;
     if (!defined $o->fd or !exists $o->{peer_opname}) {
 	my @copy = @_;
-	#warn "delay $copy[0]";
+	#my $fileno = $o->fd? fileno($o->fd) : 'undef';
+	#warn "$$: delay $copy[0] ($fileno, $o->{peer_opname})";
 	push @{$o->{delayed}}, \@copy;
 	return;
     }
@@ -404,6 +419,8 @@ sub rpc {
 	$save = $o->{pend}{$tx} = [$api, shift];
     }
 
+    warn "$$:Call($id)(".join(", ", @_).")"
+	if DEBUG_SHOW_RPCS;
     my $packed_args = pack_args($api->{req}, @_);
     croak("Attempt to invoke '$opname' with (".join(', ', @_).
 	  ") without pack template")
gdiff -up '/usr/tmp/mp13568.d/old/Event-tcp-0.13/t/join.t' '/usr/tmp/mp13568.d/new/Event-tcp-0.14/t/join.t'
Index: ./t/join.t
--- ./t/join.t	Tue Feb  1 11:49:10 2000
+++ ./t/join.t	Tue Feb  8 17:28:59 2000
@@ -2,10 +2,18 @@
 use strict;
 use Test;
 use Event qw(loop unloop);
+use Event::type qw(tcplisten tcpsession);
+
+my $debug=0;
+if ($debug) {
+    require NetServer::ProcessTop;
+}
 
 my $port = 7000 + int rand 2000;
 my $pid;
 if (($pid=fork) == 0) { # SERVER (child)
+    'NetServer::ProcessTop'->import()
+	if $debug;
     #sleep 1;
 
     my $finishing;
@@ -25,7 +33,7 @@ if (($pid=fork) == 0) { # SERVER (child)
 
     Event->tcplisten(port => $port, cb => sub {
 			 my ($w, $sock) = @_;
-			 #warn "client on ".fileno($sock);
+			 # warn "client on ".fileno($sock);
 			 my $o = Event->tcpsession(desc => 'server',
 						   fd => $sock, api => $api);
 		     });
@@ -38,6 +46,9 @@ if (($pid=fork) == 0) { # SERVER (child)
     exit loop();
 
 } else {  # CLIENT
+    'NetServer::ProcessTop'->import()
+	if $debug;
+    # $Event::DebugLevel = 4;
     my $Tests = 14;
     plan test => $Tests;
 
@@ -47,13 +58,16 @@ if (($pid=fork) == 0) { # SERVER (child)
 
     my $c = Event->tcpsession(desc => 'client', port => $port, api => $api,
 			      cb => sub {
+				  my ($w) = @_;
 				  $_[2] ||= 'ok';
-				  # warn "$_[1]: $_[2]\n";
+				  my $fn = $w->fd? fileno($w->fd) : 'undef';
+				  # warn "Status: fd=$fn $_[1], $_[2]\n";
 			      });
     ok ref $c, 'Event::tcpsession';
     
-    Event->timer(desc => 'break connection', after => 3, cb => sub {
+    Event->timer(desc => 'break connection', after => 4, cb => sub {
 		     $c->fd(undef);  # (oops! :-)
+		     # $c->debug(1);
 		     $c->now;        # otherwise wont notice
 		     #warn "Broke connection in order to test recovery...\n";
 		     $c->rpc('finishing');
@@ -65,9 +79,10 @@ if (($pid=fork) == 0) { # SERVER (child)
     Event->timer(interval => 1, cb => sub {
 		     shift->w->cancel
 			 if ++$tickled > 10;
+		     my $expect = $tickled;
 		     $c->rpc('tickle', sub {
 				 my ($o,$got) = @_; 
-				 ok $got, 'he' x $tickled;
+				 ok $got, 'he' x $expect;
 			     }, $tickled);
 		 });
 
#### End of Patch data ####

#### ApplyPatch data follows ####
# Data version        : 1.0
# Date generated      : Wed Feb 23 13:44:19 2000
# Generated by        : makepatch 2.00 (2.0BETA)
# Recurse directories : Yes
# p 'ChangeLog' 1041 951331088 0100444
# p 'lib/Event/tcpsession.pm' 10829 951331102 0100444
# p 't/join.t' 1969 950048939 0100444
#### End of ApplyPatch data ####

#### End of Patch kit [created: Wed Feb 23 13:44:19 2000] ####
#### Checksum: 310 9516 25346 ####

-- 
"May the best description of competition prevail."
          via, but not speaking for Deutsche Bank
lmpx.com only provides a reader for public news (NNTP) servers. It is not affiliated with the servers or forums shown here and is not responsible for the content of articles, which is written by their respective authors.