[Bps-public-commit] r9954 - in Net-IMAP-Server: lib/Net/IMAP lib/Net/IMAP/Server lib/Net/IMAP/Server/Command
alexmv at bestpractical.com
alexmv at bestpractical.com
Fri Dec 14 15:36:31 EST 2007
Author: alexmv
Date: Fri Dec 14 15:36:29 2007
New Revision: 9954
Modified:
Net-IMAP-Server/ (props changed)
Net-IMAP-Server/Makefile.PL
Net-IMAP-Server/lib/Net/IMAP/Server.pm
Net-IMAP-Server/lib/Net/IMAP/Server/Command/Fetch.pm
Net-IMAP-Server/lib/Net/IMAP/Server/Command/Starttls.pm
Net-IMAP-Server/lib/Net/IMAP/Server/Command/Uid.pm
Net-IMAP-Server/lib/Net/IMAP/Server/Connection.pm
Log:
r25773 at zoq-fot-pik: chmrr | 2007-12-14 15:36:19 -0500
* Use Net::Server::Coro
Modified: Net-IMAP-Server/Makefile.PL
==============================================================================
--- Net-IMAP-Server/Makefile.PL (original)
+++ Net-IMAP-Server/Makefile.PL Fri Dec 14 15:36:29 2007
@@ -7,13 +7,14 @@
license('perl');
requires('Class::Accessor');
+requires('Coro');
requires('Email::Address');
requires('Email::MIME');
requires('Email::MIME::ContentType');
requires('Email::Simple' => 1.999);
-requires('IO::Socket');
requires('IO::Socket::SSL');
requires('MIME::Base64');
+requires('Net::Server::Coro');
requires('Regexp::Common');
requires('Test::More');
Modified: Net-IMAP-Server/lib/Net/IMAP/Server.pm
==============================================================================
--- Net-IMAP-Server/lib/Net/IMAP/Server.pm (original)
+++ Net-IMAP-Server/lib/Net/IMAP/Server.pm Fri Dec 14 15:36:29 2007
@@ -3,14 +3,12 @@
use warnings;
use strict;
-use base 'Class::Accessor';
+use base qw/Net::Server::Coro Class::Accessor/;
use UNIVERSAL::require;
use Module::Refresh; # for development
use Carp;
-use IO::Select;
-use IO::Socket;
-use IO::Socket::SSL;
+use Coro;
use Net::IMAP::Server::Mailbox;
use Net::IMAP::Server::Connection;
@@ -18,70 +16,48 @@
our $VERSION = '0.001';
__PACKAGE__->mk_accessors(
- qw/socket ssl_socket select connections port auth_class model_class ssl_port/);
+ qw/connections port ssl_port auth_class model_class/);
sub new {
my $class = shift;
- return $class->SUPER::new(
+ return Class::Accessor::new($class,
{ port => 8080,
ssl_port => 0,
auth_class => "Net::IMAP::Server::DefaultAuth",
model_class => "Net::IMAP::Server::DefaultModel",
@_,
- connections => {},
+ connections => [],
}
);
}
sub run {
my $self = shift;
-
- my $lsn = IO::Socket::INET->new(
- Listen => 1,
- LocalPort => $self->port,
- ReuseAddr => 1
- );
- if ($@) { die "Listen on port " . $self->port . " failed: $@"; }
- else { warn "Listening on " . $self->port . "\n" }
- $self->socket($lsn);
- $self->select( IO::Select->new($lsn) );
-
- my $ssl;
+ my @proto = qw/TCP/;
+ my @port = $self->port;
if ($self->ssl_port) {
- $ssl = IO::Socket::SSL->new(
- Listen => 1,
- LocalPort => $self->ssl_port,
- ReuseAddr => 1
- );
- if ($@) { die "SSL Listen on port " . $self->ssl_port . " failed: $@"; }
- else { warn "SSL Listening on " . $self->ssl_port . "\n" }
- $self->ssl_socket($ssl);
- $self->select->add($ssl);
+ push @proto, "SSL";
+ push @port, $self->ssl_port;
}
+ local $Net::IMAP::Server::Server = $self;
+ $self->SUPER::run(proto => \@proto, port => \@port);
+}
- while ( $self->select and my @ready = $self->select->can_read ) {
- Module::Refresh->refresh;
- foreach my $fh (@ready) {
- if ( $fh == $lsn or (defined $ssl and $fh == $ssl)) {
-
- # Create a new socket
- my $new = $fh->accept;
- # Accept can fail; if so, ignore the connection
- $self->accept_connection($new) if $new;
- } else {
-
- # Process socket
- local $Net::IMAP::Server::Server = $self;
- local $SIG{PIPE} = sub { warn "Broken pipe\n"; $self->connections->{ $fh->fileno}->close };
- $self->connections->{ $fh->fileno }->handle_lines;
- }
- }
- }
+sub process_request {
+ my $self = shift;
+ my $handle = $self->{server}{client};
+ my $conn = Net::IMAP::Server::Connection->new(
+ io_handle => $handle,
+ server => $self,
+ );
+ $Coro::current->prio(-4);
+ push @{$self->connections}, $conn;
+ $conn->handle_lines;
}
DESTROY {
my $self = shift;
- $_->close for grep { defined $_ } values %{ $self->connections };
+ $_->close for grep { defined $_ } @{ $self->connections };
$self->socket->close if $self->socket;
}
@@ -107,7 +83,7 @@
return () unless $selected;
return grep {$_->is_auth and $_->is_selected
- and $_->selected eq $selected} values %{$self->connections};
+ and $_->selected eq $selected} @{$self->connections};
}
sub concurrent_user_connections {
@@ -117,20 +93,7 @@
return () unless $user;
return grep {$_->is_auth
- and $_->auth->user eq $user} values %{$self->connections};
-}
-
-sub accept_connection {
- my $self = shift;
- my $handle = shift;
- $handle->blocking(0);
- $self->select->add($handle);
- my $conn = Net::IMAP::Server::Connection->new(
- io_handle => $handle,
- server => $self,
- );
- $self->connections->{ $handle->fileno } = $conn;
- return $conn;
+ and $_->auth->user eq $user} @{$self->connections};
}
sub capability {
Modified: Net-IMAP-Server/lib/Net/IMAP/Server/Command/Fetch.pm
==============================================================================
--- Net-IMAP-Server/lib/Net/IMAP/Server/Command/Fetch.pm (original)
+++ Net-IMAP-Server/lib/Net/IMAP/Server/Command/Fetch.pm Fri Dec 14 15:36:29 2007
@@ -5,6 +5,8 @@
use base qw/Net::IMAP::Server::Command/;
+use Coro;
+
sub validate {
my $self = shift;
@@ -25,10 +27,10 @@
my ( $messages, $spec ) = $self->parsed_options;
my @messages = $self->connection->get_messages($messages);
for my $m (@messages) {
- return unless $self->connection->connected;
$self->untagged_response( $self->connection->sequence($m)
. " FETCH "
. $self->data_out( [ $m->fetch($spec) ] ) );
+ cede;
}
$self->ok_completed();
Modified: Net-IMAP-Server/lib/Net/IMAP/Server/Command/Starttls.pm
==============================================================================
--- Net-IMAP-Server/lib/Net/IMAP/Server/Command/Starttls.pm (original)
+++ Net-IMAP-Server/lib/Net/IMAP/Server/Command/Starttls.pm Fri Dec 14 15:36:29 2007
@@ -26,8 +26,11 @@
my $self = shift;
$self->ok_completed;
- IO::Socket::SSL->start_SSL( $self->connection->io_handle,
+ my $handle = $self->connection->io_handle;
+ $handle = tied(${$handle})->[0];
+ IO::Socket::SSL->start_SSL( $handle,
SSL_server => 1, );
+ bless $handle, "Net::Server::Proto::SSL";
}
1;
Modified: Net-IMAP-Server/lib/Net/IMAP/Server/Command/Uid.pm
==============================================================================
--- Net-IMAP-Server/lib/Net/IMAP/Server/Command/Uid.pm (original)
+++ Net-IMAP-Server/lib/Net/IMAP/Server/Command/Uid.pm Fri Dec 14 15:36:29 2007
@@ -6,6 +6,8 @@
use base qw/Net::IMAP::Server::Command/;
use Net::IMAP::Server::Command::Search;
+use Coro;
+
sub validate {
my $self = shift;
@@ -46,10 +48,10 @@
push @{$spec}, "UID" unless grep {uc $_ eq "UID"} @{$spec};
my @messages = $self->connection->selected->get_uids($messages);
for my $m (@messages) {
- return unless $self->connection->connected;
$self->untagged_response( $self->connection->sequence($m)
. " FETCH "
. $self->data_out( [ $m->fetch($spec) ] ) );
+ cede;
}
$self->ok_completed();
Modified: Net-IMAP-Server/lib/Net/IMAP/Server/Connection.pm
==============================================================================
--- Net-IMAP-Server/lib/Net/IMAP/Server/Connection.pm (original)
+++ Net-IMAP-Server/lib/Net/IMAP/Server/Connection.pm Fri Dec 14 15:36:29 2007
@@ -6,6 +6,7 @@
use base 'Class::Accessor';
use Net::IMAP::Server::Command;
+use Coro;
__PACKAGE__->mk_accessors(qw(server io_handle _selected selected_read_only model pending temporary_messages temporary_sequence_map previous_exists untagged_expunge untagged_fetch ignore_flags));
@@ -23,15 +24,13 @@
sub handle_lines {
my $self = shift;
- my $i = 0;
- ++$i and $self->handle_command($_) while $self->io_handle and $_ = $self->io_handle->getline();
-
- if ( not $i ) {
- $self->log("Connection closed by remote host");
- $self->close;
- return;
+ while ($self->io_handle and $_ = $self->io_handle->getline()) {
+ $self->handle_command($_);
+ cede;
}
+ $self->log("Connection closed by remote host");
+ $self->close;
}
sub handle_command {
@@ -42,7 +41,7 @@
local $self->server->{model} = $self->model;
local $self->server->{auth} = $self->auth;
- $self->log("C(@{[$self->io_handle->peerport]},@{[$self->auth ? $self->auth->user : '???']},@{[$self->is_selected ? $self->selected->full_path : 'unselected']}): $content");
+ $self->log("C(@{[$self]},@{[$self->auth ? $self->auth->user : '???']},@{[$self->is_selected ? $self->selected->full_path : 'unselected']}): $content");
if ( $self->pending ) {
$self->pending->($content);
@@ -78,9 +77,9 @@
sub close {
my $self = shift;
+ $self->server->connections([grep {$_ ne $self} @{$self->server->connections}]);
if ($self->io_handle) {
- delete $self->server->connections->{ $self->io_handle->fileno };
- $self->server->select->remove( $self->io_handle );
+ warn "Closing connection $self";
$self->io_handle->close;
$self->io_handle(undef);
}
@@ -124,7 +123,9 @@
sub is_encrypted {
my $self = shift;
- return $self->io_handle->isa("IO::Socket::SSL");
+ my $handle = $self->io_handle;
+ $handle = tied(${$handle})->[0];
+ return $handle->isa("IO::Socket::SSL");
}
sub auth {
@@ -257,16 +258,17 @@
my $self = shift;
my $msg = shift;
if ($self->io_handle and $self->io_handle->peerport) {
- $self->io_handle->blocking(1);
if ($self->io_handle->print($msg)) {
- $self->io_handle->blocking(0);
- $self->log("S(@{[$self->io_handle->peerport || 'undef']},@{[$self->auth ? $self->auth->user : '???']},@{[$self->is_selected ? $self->selected->full_path : 'unselected']}): $msg");
+ $self->log("S(@{[$self]},@{[$self->auth ? $self->auth->user : '???']},@{[$self->is_selected ? $self->selected->full_path : 'unselected']}): $msg");
} else {
- $self->io_handle->close if $self->io_handle;
$self->close;
+ # Bail out; never returns
+ $Coro::current->cancel;
}
} else {
$self->close;
+ # Bail out; never returns
+ $Coro::current->cancel;
}
}
More information about the Bps-public-commit
mailing list