You need a dot ('.'), not a comma (',') (and don't forget some error handling :).
open my $socket, '+<&=' . $fileno or die $!;
........................^
For an explaination of the syntax and what it is doing, see perlopentut and the section entitled "Re-Opening Files (dups)".
Sorry for not posting the code I promised. I've been trying to work it into a proper module. It works, but need substantial extra testing and documentation. I'll post it below as it is in it's current state.
The usage will be something like this:
my $server = threads::Server->new(
LocalPort => 9000,
Pool => 5,
Accept => sub {
printf "Accepted connection from %s:%d on port:%d\n",
$_->peerhost, $_->peerport, $_->sockport;
return;
},
Thread => sub {
my( $client, $Qout, @args ) = @_;
while( <$client> ) {
chomp;
##1 warnf "Got '%s'\n", $_;
$Qout->enqueue( $_ );
print $client 'Ack';
}
},
Common => sub {
my $Q = shift;
while( $Q->dequeue() ) {
#1 warnf "Processing '$_'";
}
},
);
$server->Run;
That needs explaination, documentation, a lot of work, and relies on another of my own modules (a ripoff of theDamian's Smart::Comments), but it might provide some ideas for you.
package threads::Server;
use Smart::Comments::Lite '4';
use 5.008006;
use strict;
use warnings;
use threads;
use Carp qw[ cluck ];
use Thread::Queue;
use IO::Socket;
our $VERSION = '1.0.0';
my %serverDefaults = (
Pool => 3,
Accept => sub{ undef },
Thread => sub{ warn },
Common => sub{ warn },
);
my %socketDefaults = (
LocalHost => 'localhost',
Listen => 5,
Reuse => 1,
);
sub new {
my( $class, %args ) = @_;
##4 warnf "1:%s\n", join ' ', %args;
my %self = %serverDefaults;
@self{ keys %serverDefaults } = delete @args{ keys %serverDefaults
+ };
##4 warnf "2:%s\n", join' ',%args;
@self{ qw[ Qwork Qin Qclean ] } = map{ new Thread::Queue } 1 .. 3;
@{ $self{ Threads } } = map{
threads->create( \&_thread, @self{ qw[ Thread Qwork Qin Qclean
+ ] } )
} 1 .. $self{ Pool };
threads->create( @self{ qw[ Common Qin ] } );
%args = ( %socketDefaults, %args );
##4 warnf "3:%s\n", join ' ', %args;
$self{ Socket } = IO::Socket::INET->new( %args )
or cluck __PACKAGE__ . ": failed to create listening socket: $
+!\n"
and return PACKAGE->DESTROY( \%self );
return bless \%self, $class;
}
sub Run {
my $self = $_[0];
my( $server, $Qwork, $Qclean, $accept ) = @{ $self }{ qw[ Socket
+Qwork Qclean Accept ] };
while( local $_ = $server->accept ) {
my $fileno = fileno $_;
$self->{ Clients }{ $fileno } = $_;
my $clientArgs = eval{ join chr(0), $accept->() } || '';
$Qwork->enqueue( "$fileno\0$clientArgs" );
while( $Qclean->pending ) {
##1 warnf "Cleanup of %d\n", my $fno = $Qclean->dequeue();
close delete $self->{ Clients }{ $fno };
}
}
}
sub _thread {
##1 warnf "Starting thread %d\n", threads->tid;
my( $userCode, $Qwork, $Qin, $Qclean ) = @_;
while( my $work = $Qwork->dequeue() ) {
my( $fileno, @args ) = split chr(0), $work;
open my $client, '+<&=' . $fileno
or cluck "Failed to dup $fileno in ${ \threads->tid } : $!
+\n"
and next;
$userCode->( $client, $Qin, @args );
close $client;
$Qclean->enqueue( $fileno );
}
}
sub DESTROY {
}
return 1 if caller;
local $\ = "\n";
my $server = threads::Server->new(
LocalPort => 9000,
Pool => 5,
Accept => sub {
printf "Accepted connection from %s:%d on port:%d\n",
$_->peerhost, $_->peerport, $_->sockport;
return;
},
Thread => sub {
my( $client, $Qout, @args ) = @_;
while( <$client> ) {
chomp;
##1 warnf "Got '%s'\n", $_;
$Qout->enqueue( $_ );
print $client 'Ack';
}
},
Common => sub {
my $Q = shift;
while( $Q->dequeue() ) {
#1 warnf "Processing '$_'";
}
},
);
$server->Run;
__END__
=head1 NAME
threads::Server - Perl extension for blah blah blah
=head1 SYNOPSIS
use threads::Server;
blah blah blah
=head1 DESCRIPTION
Stub documentation for threads::Server, created by h2xs. It looks like
+ the
author of the extension was negligent enough to leave the stub
unedited.
Blah blah blah.
=head2 EXPORT
None by default.
=head1 SEE ALSO
Mention other useful documentation such as the documentation of
related modules or operating system documentation (such as man pages
in UNIX), or any relevant external documentation such as RFCs or
standards.
If you have a mailing list set up for your module, mention it here.
If you have a web site set up for your module, mention it here.
=head1 AUTHOR
A. U. Thor, E<lt>a.u.thor@a.galaxy.far.far.awayE<gt>
=head1 COPYRIGHT AND LICENSE
Copyright (C) 2006 by A. U. Thor
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.6 or,
at your option, any later version of Perl 5 you may have available.
=cut
Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.
Lingua non convalesco, consenesco et abolesco. -- Rule 1 has a caveat! -- Who broke the cabal?
"Science is about questioning the status quo. Questioning authority".
In the absence of evidence, opinion is indistinguishable from prejudice.
