----- 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
