| Subject: | buffered I/O combined with select causes receive_frame to hang |
On some of my machines the attached code (brokenapachemq.t) will hang
forever when doing a receive_frame. Upon examination of the problem one
of my co-workers
noted that he had encountered the same issue, and that it was due to
getline and read being used with select in Frame.pm. He provided a fix
which solved the problem, which I have cleaned up, and I'm attaching as
a patch for Frame.pm.
The machines that have the issue are running:
Ubuntu with kernel 2.6.24-19-server #1 SMP Wed Jun 18 14:44:47 UTC 2008
x86_64 GNU/Linux
$ perl -V
Summary of my perl5 (revision 5 version 8 subversion 8) configuration:
Platform:
osname=linux, osvers=2.6.15.7, archname=x86_64-linux-gnu-thread-multi
uname='linux yellow 2.6.15.7 #1 smp sun sep 23 13:51:52 utc 2007
x86_64 gnulinux '
config_args='-Dusethreads -Duselargefiles -Dccflags=-DDEBIAN
-Dcccdlflags=-fPIC -Darchname=x86_64-linux-gnu -Dprefix=/usr
-Dprivlib=/usr/share/perl/5.8 -Darchlib=/usr/lib/perl/5.8
-Dvendorprefix=/usr -Dvendorlib=/usr/share/perl5
-Dvendorarch=/usr/lib/perl5 -Dsiteprefix=/usr/local
-Dsitelib=/usr/local/share/perl/5.8.8
-Dsitearch=/usr/local/lib/perl/5.8.8 -Dman1dir=/usr/share/man/man1
-Dman3dir=/usr/share/man/man3 -Dsiteman1dir=/usr/local/man/man1
-Dsiteman3dir=/usr/local/man/man3 -Dman1ext=1 -Dman3ext=3perl
-Dpager=/usr/bin/sensible-pager -Uafs -Ud_csh -Ud_ualarm -Uusesfio
-Uusenm -Duseshrplib -Dlibperl=libperl.so.5.8.8 -Dd_dosuid -des'
hint=recommended, useposix=true, d_sigaction=define
usethreads=define use5005threads=undef useithreads=define
usemultiplicity=define
useperlio=define d_sfio=undef uselargefiles=define usesocks=undef
use64bitint=define use64bitall=define uselongdouble=undef
usemymalloc=n, bincompat5005=undef
Compiler:
cc='cc', ccflags ='-D_REENTRANT -D_GNU_SOURCE -DTHREADS_HAVE_PIDS
-DDEBIAN -fno-strict-aliasing -pipe -I/usr/local/include
-D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64',
optimize='-O2',
cppflags='-D_REENTRANT -D_GNU_SOURCE -DTHREADS_HAVE_PIDS -DDEBIAN
-fno-strict-aliasing -pipe -I/usr/local/include'
ccversion='', gccversion='4.2.3 20071123 (prerelease) (Ubuntu
4.2.2-3ubuntu4)', gccosandvers=''
intsize=4, longsize=8, ptrsize=8, doublesize=8, byteorder=12345678
d_longlong=define, longlongsize=8, d_longdbl=define, longdblsize=16
ivtype='long', ivsize=8, nvtype='double', nvsize=8, Off_t='off_t',
lseeksize=8
alignbytes=8, prototype=define
Linker and Libraries:
ld='cc', ldflags =' -L/usr/local/lib'
libpth=/usr/local/lib /lib /usr/lib
libs=-lgdbm -lgdbm_compat -ldb -ldl -lm -lpthread -lc -lcrypt
perllibs=-ldl -lm -lpthread -lc -lcrypt
libc=/lib/libc-2.6.1.so, so=so, useshrplib=true,
libperl=libperl.so.5.8.8
gnulibc_version='2.6.1'
Dynamic Linking:
dlsrc=dl_dlopen.xs, dlext=so, d_dlsymun=undef, ccdlflags='-Wl,-E'
cccdlflags='-fPIC', lddlflags='-shared -L/usr/local/lib'
Characteristics of this binary (from libperl):
Compile-time options: MULTIPLICITY PERL_IMPLICIT_CONTEXT
PERL_MALLOC_WRAP THREADS_HAVE_PIDS USE_64_BIT_ALL
USE_64_BIT_INT USE_ITHREADS USE_LARGE_FILES
USE_PERLIO USE_REENTRANT_API
Built under linux
Compiled at Nov 27 2007 10:56:40
@INC:
/etc/perl
/usr/local/lib/perl/5.8.8
/usr/local/share/perl/5.8.8
/usr/lib/perl5
/usr/share/perl5
/usr/lib/perl/5.8
/usr/share/perl/5.8
/usr/local/lib/site_perl
.
Class::Accessor::Fast 0.31
IO::Socket::INET 1.31
IO::Select 1.17
| Subject: | brokenapachemq.t |
#!/usr/bin/perl
use lib '/web/apps/lib';
use Net::Stomp;
my $stomp_host =
'192.168.20.76';
my $stomp_port = '61613';
my $stomp;
$stomp = Net::Stomp->new({
hostname => $stomp_host,
port => $stomp_port,
});
$stomp->connect({
login => 'foo',
passcode => 'bar',
});
$stomp->subscribe({
destination => '/queue/testbrokenapachemq',
ack => 'client',
'activemq.dispatchAsync' => 0,
'activemq.prefetchSize' => 1,
});
my $body = "z";
my $frame = Net::Stomp::Frame->new({
command => 'SEND',
body => $body,
headers => {
destination => '/queue/testbrokenapachemq',
name => 'foobarbaz',
JSMXGroupID => 'XXX',
},
});
$stomp->send_frame($frame);
print "frame $body sent\n";
$body = "x";
$frame = Net::Stomp::Frame->new({
command => 'SEND',
body => $body,
headers => {
destination => '/queue/testbrokenapachemq',
name => 'foobarbaz',
JSMXGroupID => 'XXX',
},
});
$stomp->send_frame($frame);
print "frame $body sent\n";
$body = "y";
$frame = Net::Stomp::Frame->new({
command => 'SEND',
body => $body,
headers => {
destination => '/queue/testbrokenapachemq',
name => 'foobarbaz',
JSMXGroupID => 'XXX',
},
});
$stomp->send_frame($frame);
print "frame $body sent\n";
print "Broken if this hangs forever\n";
my $count = 0;
while (1) {
if (eval {$frame = $stomp->receive_frame}) {
print "GOT FRAME ".$frame->body."\n";
$stomp->ack({frame => $frame});
$count++;
last if $count == 3;
}
}
print "Success\n";
| Subject: | frame.patch |
--- lib/Net/Stomp/Frame.pm 2008-06-27 01:31:46.000000000 -0700
+++ ../Net-Stomp-0.34.patch/lib/Net/Stomp/Frame.pm 2009-03-27 14:09:54.000000000 -0700
@@ -27,6 +27,23 @@
$frame .= "\000";
}
+# NBK - $sock->getline does buffered IO which screws up select. Use
+# sysread one char at a time to avoid reading part of the next line.
+sub readline {
+ my($self, $socket, $terminator, $msg) = @_;
+
+ $terminator = "\n" unless defined($terminator);
+ $msg ||= "";
+
+ my $s = "";
+ while( 1 ) {
+ $socket->sysread($s, 1, length($s)) or die("Error reading $msg: $!");
+ last if substr($s, -1) eq $terminator;
+ }
+
+ return $s;
+}
+
sub parse {
my ( $package, $socket ) = @_;
local $/ = "\n";
@@ -34,7 +51,7 @@
# read the command
my $command;
while (1) {
- $command = $socket->getline || die "Error reading command: $!";
+ $command = $package->readline($socket, "\n", "command");
chop $command;
last if $command;
}
@@ -42,31 +59,29 @@
# read headers
my $headers;
while (1) {
- my $line = $socket->getline || die "Error reading header: $!";
+ my $line = $package->readline($socket, "\n", "header");
chop $line;
last if $line eq "";
- my ( $key, $value ) = split /: ?/, $line, 2;
+ my ( $key, $value ) = split(/: ?/, $line, 2);
$headers->{$key} = $value;
}
# read the body
my $body;
+ my $c;
if ( $headers->{"content-length"} ) {
- $socket->read( $body, $headers->{"content-length"} )
+ $socket->sysread( $body, $headers->{"content-length"} + 1 )
|| die "Error reading body: $!";
- $socket->getc; # eat the trailing null
$headers->{bytes_message} = 1;
} else {
- while (1) {
- my $byte = $socket->getc;
- die "Error reading body: $!" unless defined $byte;
- last if $byte eq "\000";
- $body .= $byte;
- }
+ $body = $package->readline($socket, "\000", "body");
}
-
+ # strip trailing null
+ $body =~ s/\000$//;
+
my $frame = Net::Stomp::Frame->new(
{ command => $command, headers => $headers, body => $body } );
+
return $frame;
}