[Bps-public-commit] r9312 - in Net-Server-IMAP: . lib/Net/Server/IMAP lib/Net/Server/IMAP/Command
alexmv at bestpractical.com
alexmv at bestpractical.com
Mon Oct 15 19:53:40 EDT 2007
Author: alexmv
Date: Mon Oct 15 19:53:35 2007
New Revision: 9312
Modified:
Net-Server-IMAP/ (props changed)
Net-Server-IMAP/lib/Net/Server/IMAP.pm
Net-Server-IMAP/lib/Net/Server/IMAP/Command.pm
Net-Server-IMAP/lib/Net/Server/IMAP/Command/Authenticate.pm
Net-Server-IMAP/lib/Net/Server/IMAP/Command/Capability.pm
Net-Server-IMAP/lib/Net/Server/IMAP/Command/Check.pm
Net-Server-IMAP/lib/Net/Server/IMAP/Command/Close.pm
Net-Server-IMAP/lib/Net/Server/IMAP/Command/Create.pm
Net-Server-IMAP/lib/Net/Server/IMAP/Command/Expunge.pm
Net-Server-IMAP/lib/Net/Server/IMAP/Command/Fetch.pm
Net-Server-IMAP/lib/Net/Server/IMAP/Command/List.pm
Net-Server-IMAP/lib/Net/Server/IMAP/Command/Login.pm
Net-Server-IMAP/lib/Net/Server/IMAP/Command/Logout.pm
Net-Server-IMAP/lib/Net/Server/IMAP/Command/Noop.pm
Net-Server-IMAP/lib/Net/Server/IMAP/Command/Select.pm
Net-Server-IMAP/lib/Net/Server/IMAP/Command/Starttls.pm
Net-Server-IMAP/lib/Net/Server/IMAP/Command/Status.pm
Net-Server-IMAP/lib/Net/Server/IMAP/Command/Store.pm
Net-Server-IMAP/lib/Net/Server/IMAP/Command/Subscribe.pm
Net-Server-IMAP/lib/Net/Server/IMAP/Command/Uid.pm
Net-Server-IMAP/lib/Net/Server/IMAP/Connection.pm
Net-Server-IMAP/lib/Net/Server/IMAP/DefaultModel.pm
Net-Server-IMAP/lib/Net/Server/IMAP/Message.pm
Log:
r23608 at zoq-fot-pik: chmrr | 2007-10-15 16:09:25 -0400
* More standardized argument parsing
Modified: Net-Server-IMAP/lib/Net/Server/IMAP.pm
==============================================================================
--- Net-Server-IMAP/lib/Net/Server/IMAP.pm (original)
+++ Net-Server-IMAP/lib/Net/Server/IMAP.pm Mon Oct 15 19:53:35 2007
@@ -41,7 +41,7 @@
ReuseAddr => 1
);
if ($@) { die "Listen on port " . $self->port . " failed: $@"; }
- else { warn "Listening on " . $self->port }
+ else { warn "Listening on " . $self->port . "\n" }
$self->socket($lsn);
$self->select( IO::Select->new($lsn) );
while ( $self->select ) {
Modified: Net-Server-IMAP/lib/Net/Server/IMAP/Command.pm
==============================================================================
--- Net-Server-IMAP/lib/Net/Server/IMAP/Command.pm (original)
+++ Net-Server-IMAP/lib/Net/Server/IMAP/Command.pm Mon Oct 15 19:53:35 2007
@@ -5,7 +5,19 @@
use base 'Class::Accessor';
use Regexp::Common qw/delimited/;
-__PACKAGE__->mk_accessors(qw(server connection command_id options command));
+__PACKAGE__->mk_accessors(qw(server connection command_id options_str command _parsed_options _literals));
+
+sub new {
+ my $class = shift;
+ my $self = $class->SUPER::new(@_);
+ $self->_parsed_options([]);
+ $self->_literals([]);
+ return $self;
+}
+
+sub validate {
+ return 1;
+}
sub run {
my $self = shift;
@@ -13,12 +25,63 @@
$self->bad_command( "command '" . $self->command . "' not recognized" );
}
-sub parsed_options {
+sub has_literal {
my $self = shift;
+ unless ($self->options_str =~ /\{(\d+)\}$/) {
+ $self->parse_options;
+ return;
+ }
- return
- map { s/^"(.*)"$/$1/; $_ }
- grep {/\S/} split /($RE{delimited}{-delim=>'"'}|\S+)/, $self->options;
+ my $options = $self->options_str;
+ my $next = $#{$self->_literals} + 1;
+ $options =~ s/\{(\d+)\}$/{{$next}}/;
+ my $length = $1;
+ $self->options_str($options);
+
+ # Pending
+ $self->connection->pending(sub {
+ my $content = shift;
+ {
+ use bytes;
+ $self->_literals->[$next] = substr($content, 0, $length, "");
+ }
+ $self->connection->pending(undef);
+ $self->options_str($self->options_str . $content);
+ return if $self->has_literal;
+ $self->run if $self->validate;
+ });
+ $self->out( "+ Continue\r\n" );
+ return 1;
+}
+
+sub parse_options {
+ my $self = shift;
+ my $str = shift;
+
+ return $self->_parsed_options if not defined $str and not defined $self->options_str;
+
+ my @parsed;
+ for my $term (grep {/\S/} split /($RE{delimited}{-delim=>'"'}|$RE{balanced}{-parens=>'()'}|\S+)/, $str || $self->options_str) {
+ if ($term =~ /^$RE{delimited}{-delim=>'"'}{-keep}$/) {
+ push @parsed, $3;
+ } elsif ($term =~ /^$RE{balanced}{-parens=>'()'}$/) {
+ $term =~ s/^\((.*)\)$/$1/;
+ push @parsed, [$self->parse_options($term)];
+ } elsif ($term =~ /^\{\{(\d+)\}\}$/) {
+ push @parsed, $self->_literals->[$1];
+ } else {
+ push @parsed, $term;
+ }
+ }
+ return @parsed if defined $str;
+
+ $self->options_str(undef);
+ $self->_parsed_options([@{$self->_parsed_options}, @parsed]);
+}
+
+sub parsed_options {
+ my $self = shift;
+ return @{$self->_parsed_options(@_)};
}
sub data_out {
@@ -31,7 +94,7 @@
} elsif ( not ref $data ) {
if ( not defined $data ) {
return "NIL";
- } elsif ( $data =~ /["\r\n]/ ) {
+ } elsif ( $data =~ /[{"\r\n%*\\\[]/ ) {
return "{" . ( length($data) ) . "}\r\n$data";
} elsif ( $data =~ /^\d+$/ ) {
return $data;
@@ -68,6 +131,7 @@
}
$self->log("OK Request: $message");
$self->out( $self->command_id . " " . "OK " . $message . "\r\n" );
+ return 1;
}
sub no_command {
@@ -80,6 +144,7 @@
}
$self->log("NO Request: $message");
$self->out( $self->command_id . " " . "NO " . $message . "\r\n" );
+ return 0;
}
sub no_failed {
@@ -90,8 +155,7 @@
sub no_unimplemented {
my $self = shift;
- $self->no_failed( alert => $self->options
- . " unimplemented. sorry. We'd love patches!" );
+ $self->no_failed( alert => "Feature unimplemented. sorry. We'd love patches!" );
}
sub ok_completed {
@@ -106,6 +170,7 @@
my $reason = shift;
$self->log("BAD Request: $reason");
$self->out( $self->command_id . " " . "BAD " . $reason . "\r\n" );
+ return 0;
}
sub log {
Modified: Net-Server-IMAP/lib/Net/Server/IMAP/Command/Authenticate.pm
==============================================================================
--- Net-Server-IMAP/lib/Net/Server/IMAP/Command/Authenticate.pm (original)
+++ Net-Server-IMAP/lib/Net/Server/IMAP/Command/Authenticate.pm Mon Oct 15 19:53:35 2007
@@ -4,25 +4,34 @@
use strict;
use MIME::Base64;
-use base qw/Class::Accessor Net::Server::IMAP::Command/;
+use base qw/Net::Server::IMAP::Command/;
__PACKAGE__->mk_accessors(qw(sasl pending_auth));
-sub run {
+sub validate {
my $self = shift;
return $self->bad_command("Already logged in")
unless $self->connection->is_unauth;
- my ($type) = $self->parsed_options;
+ my @options = $self->parsed_options;
+ return $self->bad_command("Not enough options") if @options < 1;
+ return $self->bad_command("Too many options") if @options > 1;
+
+ return 1;
+}
+
+sub run {
+ my $self = shift;
+ my($type) = $self->parsed_options;
$self->server->auth_class->require || warn $@;
my $auth = $self->server->auth_class->new;
if ( $auth->provides_sasl( uc $type ) ) {
$type = lc $type;
$self->sasl( $auth->$type() );
$self->pending_auth($auth);
- $self->connection->pending($self);
+ $self->connection->pending(sub {$self->continue(@_)});
$self->continue("");
} else {
$self->bad_command("Invalid login");
Modified: Net-Server-IMAP/lib/Net/Server/IMAP/Command/Capability.pm
==============================================================================
--- Net-Server-IMAP/lib/Net/Server/IMAP/Command/Capability.pm (original)
+++ Net-Server-IMAP/lib/Net/Server/IMAP/Command/Capability.pm Mon Oct 15 19:53:35 2007
@@ -5,6 +5,15 @@
use base qw/Net::Server::IMAP::Command/;
+sub validate {
+ my $self = shift;
+
+ my @options = $self->parsed_options;
+ return $self->bad_command("Too many options") if @options;
+
+ return 1;
+}
+
sub run {
my $self = shift;
$self->tagged_response( $self->server->capability );
Modified: Net-Server-IMAP/lib/Net/Server/IMAP/Command/Check.pm
==============================================================================
--- Net-Server-IMAP/lib/Net/Server/IMAP/Command/Check.pm (original)
+++ Net-Server-IMAP/lib/Net/Server/IMAP/Command/Check.pm Mon Oct 15 19:53:35 2007
@@ -5,8 +5,16 @@
use base qw/Net::Server::IMAP::Command/;
-sub run {
+sub validate {
my $self = shift;
+
+ my @options = $self->parsed_options;
+ return $self->bad_command("Too many options") if @options;
+
+ return 1;
+}
+
+sub run {
$self->ok_completed();
}
Modified: Net-Server-IMAP/lib/Net/Server/IMAP/Command/Close.pm
==============================================================================
--- Net-Server-IMAP/lib/Net/Server/IMAP/Command/Close.pm (original)
+++ Net-Server-IMAP/lib/Net/Server/IMAP/Command/Close.pm Mon Oct 15 19:53:35 2007
@@ -5,13 +5,22 @@
use base qw/Net::Server::IMAP::Command/;
-sub run {
+sub validate {
my $self = shift;
return $self->bad_command("Log in first") if $self->connection->is_unauth;
return $self->bad_command("Select a mailbox first")
unless $self->connection->is_selected;
+ my @options = $self->parsed_options;
+ return $self->bad_command("Too many options") if @options;
+
+ return 1;
+}
+
+sub run {
+ my $self = shift;
+
$self->connection->selected(undef);
$self->ok_completed();
Modified: Net-Server-IMAP/lib/Net/Server/IMAP/Command/Create.pm
==============================================================================
--- Net-Server-IMAP/lib/Net/Server/IMAP/Command/Create.pm (original)
+++ Net-Server-IMAP/lib/Net/Server/IMAP/Command/Create.pm Mon Oct 15 19:53:35 2007
@@ -1,15 +1,30 @@
package Net::Server::IMAP::Command::Create;
+
+use warnings;
+use strict;
+
use base qw/Net::Server::IMAP::Command/;
-sub run {
+sub validate {
my $self = shift;
+ # TODO: ???
return $self->no_command("Permission denied");
- my ($name) = $self->parsed_options;
+ my @options = $self->parsed_options;
+ return $self->bad_command("Not enough options") if @options < 1;
+ return $self->bad_command("Too many options") if @options > 1;
+
+ my $name = shift @options;
my $mailbox = $self->connection->model->lookup($name);
return $self->no_command("Mailbox already exists") if $mailbox;
+ return 1;
+}
+
+sub run {
+ my $self = shift;
+
my $root = $self->connection->model->root;
$self->connection->model->add_child( $root, name => $name );
Modified: Net-Server-IMAP/lib/Net/Server/IMAP/Command/Expunge.pm
==============================================================================
--- Net-Server-IMAP/lib/Net/Server/IMAP/Command/Expunge.pm (original)
+++ Net-Server-IMAP/lib/Net/Server/IMAP/Command/Expunge.pm Mon Oct 15 19:53:35 2007
@@ -5,15 +5,23 @@
use base qw/Net::Server::IMAP::Command/;
-sub run {
+sub validate {
my $self = shift;
return $self->bad_command("Log in first") if $self->connection->is_unauth;
return $self->bad_command("Select a mailbox first")
unless $self->connection->is_selected;
- my @ids = $self->connection->selected->expunge;
+ my @options = $self->parsed_options;
+ return $self->bad_command("Too many options") if @options;
+
+ return 1;
+}
+sub run {
+ my $self = shift;
+
+ my @ids = $self->connection->selected->expunge;
$self->untagged_response( map {"$_ EXPUNGE"} @ids );
$self->ok_completed();
Modified: Net-Server-IMAP/lib/Net/Server/IMAP/Command/Fetch.pm
==============================================================================
--- Net-Server-IMAP/lib/Net/Server/IMAP/Command/Fetch.pm (original)
+++ Net-Server-IMAP/lib/Net/Server/IMAP/Command/Fetch.pm Mon Oct 15 19:53:35 2007
@@ -1,16 +1,28 @@
package Net::Server::IMAP::Command::Fetch;
+
+use warnings;
+use strict;
+
use base qw/Net::Server::IMAP::Command/;
-sub run {
+sub validate {
my $self = shift;
return $self->bad_command("Login first") if $self->connection->is_unauth;
return $self->bad_command("Select a mailbox first")
unless $self->connection->is_selected;
- my $options = $self->options;
- my ( $messages, $spec ) = split( ' ', $options, 2 );
+ my @options = $self->parsed_options;
+ return $self->bad_command("Not enough options") if @options < 2;
+ return $self->bad_command("Too many options") if @options > 2;
+
+ return 1;
+}
+
+sub run {
+ my $self = shift;
+ my ( $messages, $spec ) = $self->parsed_options;
my @messages = $self->connection->selected->get_messages($messages);
for (@messages) {
$self->untagged_response( $_->sequence
Modified: Net-Server-IMAP/lib/Net/Server/IMAP/Command/List.pm
==============================================================================
--- Net-Server-IMAP/lib/Net/Server/IMAP/Command/List.pm (original)
+++ Net-Server-IMAP/lib/Net/Server/IMAP/Command/List.pm Mon Oct 15 19:53:35 2007
@@ -5,26 +5,33 @@
use base qw/Net::Server::IMAP::Command/;
-sub run {
+sub validate {
my $self = shift;
return $self->bad_command("Log in first") if $self->connection->is_unauth;
- my @args = $self->parsed_options;
+ my @options = $self->parsed_options;
+ return $self->bad_command("Not enough options") if @options < 2;
+ return $self->bad_command("Too many options") if @options > 2;
+
+ return 1;
+}
- return $self->bad_command("Wrong arugments") unless @args == 2;
+sub run {
+ my $self = shift;
- my ( $root, $search ) = @args;
+ my ( $root, $search ) = $self->parsed_options;
- # In the special case of a query for the delimiter, give them our delimiter
+ # In the special case of a query for the delimiter, give them our delimiter
if ( $search eq "" ) {
$self->tagged_response( q{(\Noselect) "}
. $self->connection->model->seperator
. q{" ""} );
} else {
my $sep = $self->connection->model->seperator;
- $search =~ s/\*/.*/g;
- $search =~ s/%/[^$sep]/g;
+ $search = quotemeta($search);
+ $search =~ s/\\\*/.*/g;
+ $search =~ s/\\%/[^$sep]/g;
my $regex = qr{^\Q$root\E$search$};
$self->traverse( $self->connection->model->root, $regex );
}
Modified: Net-Server-IMAP/lib/Net/Server/IMAP/Command/Login.pm
==============================================================================
--- Net-Server-IMAP/lib/Net/Server/IMAP/Command/Login.pm (original)
+++ Net-Server-IMAP/lib/Net/Server/IMAP/Command/Login.pm Mon Oct 15 19:53:35 2007
@@ -5,12 +5,22 @@
use base qw/Net::Server::IMAP::Command/;
-sub run {
+sub validate {
my $self = shift;
return $self->bad_command("Already logged in")
unless $self->connection->is_unauth;
+ my @options = $self->parsed_options;
+ return $self->bad_command("Not enough options") if @options < 2;
+ return $self->bad_command("Too many options") if @options > 2;
+
+ return 1;
+}
+
+sub run {
+ my $self = shift;
+
$self->server->auth_class->require || warn $@;
my $auth = $self->server->auth_class->new;
if ( $auth->provides_plain
Modified: Net-Server-IMAP/lib/Net/Server/IMAP/Command/Logout.pm
==============================================================================
--- Net-Server-IMAP/lib/Net/Server/IMAP/Command/Logout.pm (original)
+++ Net-Server-IMAP/lib/Net/Server/IMAP/Command/Logout.pm Mon Oct 15 19:53:35 2007
@@ -5,8 +5,18 @@
use base qw/Net::Server::IMAP::Command/;
+sub validate {
+ my $self = shift;
+
+ my @options = $self->parsed_options;
+ return $self->bad_command("Too many options") if @options;
+
+ return 1;
+}
+
sub run {
my $self = shift;
+
$self->untagged_response('BYE Ok. I love you. Buhbye!');
$self->ok_completed();
$self->connection->close();
Modified: Net-Server-IMAP/lib/Net/Server/IMAP/Command/Noop.pm
==============================================================================
--- Net-Server-IMAP/lib/Net/Server/IMAP/Command/Noop.pm (original)
+++ Net-Server-IMAP/lib/Net/Server/IMAP/Command/Noop.pm Mon Oct 15 19:53:35 2007
@@ -5,8 +5,18 @@
use base qw/Net::Server::IMAP::Command/;
+sub validate {
+ my $self = shift;
+
+ my @options = $self->parsed_options;
+ return $self->bad_command("Too many options") if @options;
+
+ return 1;
+}
+
sub run {
my $self = shift;
+
$self->ok_completed();
}
Modified: Net-Server-IMAP/lib/Net/Server/IMAP/Command/Select.pm
==============================================================================
--- Net-Server-IMAP/lib/Net/Server/IMAP/Command/Select.pm (original)
+++ Net-Server-IMAP/lib/Net/Server/IMAP/Command/Select.pm Mon Oct 15 19:53:35 2007
@@ -5,14 +5,26 @@
use base qw/Net::Server::IMAP::Command/;
-sub run {
+sub validate {
my $self = shift;
return $self->bad_command("Log in first") if $self->connection->is_unauth;
- my $mailbox = $self->connection->model->lookup( $self->parsed_options );
+ my @options = $self->parsed_options;
+ return $self->bad_command("Not enough options") if @options < 1;
+ return $self->bad_command("Too many options") if @options > 1;
+
+ my $mailbox = $self->connection->model->lookup( @options );
return $self->no_command("Mailbox does not exist") unless $mailbox;
+ return 1;
+}
+
+
+sub run {
+ my $self = shift;
+
+ my $mailbox = $self->connection->model->lookup( $self->parsed_options );
$mailbox->force_read_only(1) if $self->command eq "Examine";
$self->connection->selected($mailbox);
Modified: Net-Server-IMAP/lib/Net/Server/IMAP/Command/Starttls.pm
==============================================================================
--- Net-Server-IMAP/lib/Net/Server/IMAP/Command/Starttls.pm (original)
+++ Net-Server-IMAP/lib/Net/Server/IMAP/Command/Starttls.pm Mon Oct 15 19:53:35 2007
@@ -7,10 +7,19 @@
use IO::Socket::SSL;
+sub validate {
+ my $self = shift;
+
+ my @options = $self->parsed_options;
+ return $self->bad_command("Too many options") if @options;
+
+ return 1;
+}
+
sub run {
my $self = shift;
- $self->ok_completed;
+ $self->ok_completed;
IO::Socket::SSL->start_SSL( $self->connection->io_handle,
SSL_server => 1, );
}
Modified: Net-Server-IMAP/lib/Net/Server/IMAP/Command/Status.pm
==============================================================================
--- Net-Server-IMAP/lib/Net/Server/IMAP/Command/Status.pm (original)
+++ Net-Server-IMAP/lib/Net/Server/IMAP/Command/Status.pm Mon Oct 15 19:53:35 2007
@@ -5,20 +5,31 @@
use base qw/Net::Server::IMAP::Command/;
-sub run {
+sub validate {
my $self = shift;
return $self->bad_command("Log in first") if $self->connection->is_unauth;
- return $self->bad_command("Bad arguments to STATUS")
- unless $self->options =~ /(\w+)\s+\((.*?)\)/;
- my ( $name, @options ) = ( $1, split ' ', $2 );
+ my @options = $self->parsed_options;
+ return $self->bad_command("Not enough options") if @options == 0;
+ return $self->bad_command("Too many options") if @options > 2;
+
+ my ( $name, $flags ) = @options;
+ return $self->bad_command("Wrong second option") unless ref $flags;
my $mailbox = $self->server->mailbox( $self->connection, $name );
return $self->no_command("Mailbox does not exist") unless $mailbox;
+ return 1;
+}
+
+sub run {
+ my $self = shift;
+
+ my $mailbox = $self->server->mailbox( $self->connection, $name );
+
my %items;
- $items{ uc $_ } = undef for @options;
+ $items{ uc $_ } = undef for @{$flags};
for my $i ( keys %items ) {
if ( $i eq "MESSAGES" ) {
Modified: Net-Server-IMAP/lib/Net/Server/IMAP/Command/Store.pm
==============================================================================
--- Net-Server-IMAP/lib/Net/Server/IMAP/Command/Store.pm (original)
+++ Net-Server-IMAP/lib/Net/Server/IMAP/Command/Store.pm Mon Oct 15 19:53:35 2007
@@ -1,18 +1,29 @@
package Net::Server::IMAP::Command::Store;
+
+use warnings;
+use strict;
+
use base qw/Net::Server::IMAP::Command/;
-sub run {
+sub validate {
my $self = shift;
return $self->bad_command("Login first") if $self->connection->is_unauth;
return $self->bad_command("Select a mailbox first")
unless $self->connection->is_selected;
- my $options = $self->options;
- my ( $messages, $what, $flags ) = split( /\s+/, $options, 3 );
- $flags =~ s/^\(//;
- $flags =~ s/\)$//;
- my @flags = split ' ', $flags;
+ my @options = $self->parsed_options;
+ return $self->bad_command("Not enough options") if @options < 3;
+ return $self->bad_command("Too many options") if @options > 3;
+
+ return 1;
+}
+
+sub run {
+ my $self = shift;
+
+ my ( $messages, $what, @flags ) = $self->parsed_options;
+ @flags = map {ref $_ ? @{$_} : $_} @flags;
my @messages = $self->connection->selected->get_messages($messages);
for my $m (@messages) {
$m->store( $what => @flags );
Modified: Net-Server-IMAP/lib/Net/Server/IMAP/Command/Subscribe.pm
==============================================================================
--- Net-Server-IMAP/lib/Net/Server/IMAP/Command/Subscribe.pm (original)
+++ Net-Server-IMAP/lib/Net/Server/IMAP/Command/Subscribe.pm Mon Oct 15 19:53:35 2007
@@ -5,8 +5,22 @@
use base qw/Net::Server::IMAP::Command/;
+sub validate {
+ my $self = shift;
+
+ my @options = $self->parsed_options;
+ return $self->bad_command("Not enough options") if @options < 1;
+ return $self->bad_command("Too many options") if @options > 1;
+
+ my $mailbox = $self->connection->model->lookup( @options );
+ return $self->no_command("Mailbox does not exist") unless $mailbox;
+
+ return 1;
+}
+
sub run {
my $self = shift;
+
$self->ok_completed();
}
Modified: Net-Server-IMAP/lib/Net/Server/IMAP/Command/Uid.pm
==============================================================================
--- Net-Server-IMAP/lib/Net/Server/IMAP/Command/Uid.pm (original)
+++ Net-Server-IMAP/lib/Net/Server/IMAP/Command/Uid.pm Mon Oct 15 19:53:35 2007
@@ -1,15 +1,25 @@
package Net::Server::IMAP::Command::Uid;
use base qw/Net::Server::IMAP::Command/;
-sub run {
+sub validate {
my $self = shift;
return $self->bad_command("Select a mailbox first")
unless $self->connection->is_selected;
- if ( $self->options =~ /^(copy|fetch|store|search)\s+(.*?)$/i ) {
- my $subcommand = lc $1;
- $self->$subcommand($2);
+ my @options = $self->parsed_options;
+ return $self->bad_command("Not enough options") if @options < 1;
+
+ return 1;
+}
+
+sub run {
+ my $self = shift;
+
+ my ($subcommand, @rest) = $self->parsed_options;
+ $subcommand = lc $subcommand;
+ if ($subcommand =~ /^(copy|fetch|store|search)$/i ) {
+ $self->$subcommand(@rest);
} else {
$self->log(
$self->options . " wasn't understood by the 'UID' command" );
@@ -39,10 +49,10 @@
sub fetch {
my $self = shift;
- my $args = shift;
- my ( $messages, $spec ) = split( /\s+/, $args, 2 );
- $spec =~ s/^(\()?/$1UID / unless $spec =~ /\bUID\b/;
+ my ( $messages, $spec ) = @_;
+ $spec = [$spec] unless ref $spec;
+ push @{$spec}, "UID" unless grep {uc $_ eq "UID"} @{$spec};
my @messages = $self->get_uids($messages);
for my $m (@messages) {
$self->untagged_response( $m->sequence
@@ -55,18 +65,15 @@
sub store {
my $self = shift;
- my $args = shift;
- my ( $messages, $what, $flags ) = split( /\s+/, $args, 3 );
- $flags =~ s/^\(//;
- $flags =~ s/\)$//;
- my @flags = split ' ', $flags;
+ my ( $messages, $what, @flags ) = @_;
+ @flags = map {ref $_ ? @{$_} : $_} @flags;
my @messages = $self->get_uids($messages);
for my $m (@messages) {
$m->store( $what => @flags );
$self->untagged_response( $m->sequence
. " FETCH "
- . $self->data_out( [ $m->fetch("UID FLAGS") ] ) )
+ . $self->data_out( [ $m->fetch([qw/UID FLAGS/]) ] ) )
unless $what =~ /\.SILENT$/i;
}
Modified: Net-Server-IMAP/lib/Net/Server/IMAP/Connection.pm
==============================================================================
--- Net-Server-IMAP/lib/Net/Server/IMAP/Connection.pm (original)
+++ Net-Server-IMAP/lib/Net/Server/IMAP/Connection.pm Mon Oct 15 19:53:35 2007
@@ -25,11 +25,6 @@
my $self = shift;
my $content = $self->io_handle->getline();
- if ( $self->pending ) {
- $self->pending->continue($content);
- return;
- }
-
unless ( defined $content ) {
$self->log("Connection closed by remote host");
$self->close;
@@ -38,6 +33,11 @@
$self->log("C: $content");
+ if ( $self->pending ) {
+ $self->pending->($content);
+ return;
+ }
+
my ( $id, $cmd, $options ) = $self->parse_command($content);
return unless defined $id;
@@ -47,15 +47,16 @@
$cmd_class = "Net::Server::IMAP::Command";
}
my $handler = $cmd_class->new(
- { server => $self->server,
- connection => $self,
- options => $options,
- command_id => $id,
- command => $cmd
+ { server => $self->server,
+ connection => $self,
+ options_str => $options,
+ command_id => $id,
+ command => $cmd
}
);
+ return if $handler->has_literal;
- $handler->run();
+ $handler->run() if $handler->validate;
}
sub close {
Modified: Net-Server-IMAP/lib/Net/Server/IMAP/DefaultModel.pm
==============================================================================
--- Net-Server-IMAP/lib/Net/Server/IMAP/DefaultModel.pm (original)
+++ Net-Server-IMAP/lib/Net/Server/IMAP/DefaultModel.pm Mon Oct 15 19:53:35 2007
@@ -37,6 +37,7 @@
sub lookup {
my $self = shift;
my $name = shift;
+ $name = "INBOX" if uc $name eq "INBOX";
my @parts = split $self->seperator, $name;
return undef unless @parts and shift @parts eq $self->root->name;
my $part = $self->root;
Modified: Net-Server-IMAP/lib/Net/Server/IMAP/Message.pm
==============================================================================
--- Net-Server-IMAP/lib/Net/Server/IMAP/Message.pm (original)
+++ Net-Server-IMAP/lib/Net/Server/IMAP/Message.pm Mon Oct 15 19:53:35 2007
@@ -59,23 +59,19 @@
my $self = shift;
my $spec = shift;
- $spec = "(FLAGS INTERNALDATE RFC822.SIZE ENVELOPE)" if $spec eq "ALL";
- $spec = "(FLAGS INTERNALDATE RFC822.SIZE)" if $spec eq "FAST";
- $spec = "(FLAGS INTERNALDATE RFC822.SIZE ENVELOPE BODY)"
- if $spec eq "FULL";
-
- # This is more lenient than the spec says
- $spec =~ s/^\(//;
- $spec =~ s/\)$//;
- my @parts = grep {/\S/}
- split /([\w\.]+(?:$RE{balanced}{-parens=>'[]()'})?|\s+)/, $spec;
+ $spec = [qw/FLAGS INTERNALDATE RFC822.SIZE ENVELOPE/] if uc $spec eq "ALL";
+ $spec = [qw/FLAGS INTERNALDATE RFC822.SIZE/] if uc $spec eq "FAST";
+ $spec = [qw/FLAGS INTERNALDATE RFC822.SIZE ENVELOPE BODY/]
+ if uc $spec eq "FULL";
+
+ my @parts = ref $spec ? @{$spec} : $spec;
# Look if this will change the \Seen flag
if ( grep { $_ =~ /^BODY\[/i } @parts and not $self->has_flag('\Seen') ) {
# If so, update, and possibly also inform the user.
$self->set_flag('\Seen');
- push @parts, "FLAGS" if not grep { $_ eq "FLAGS" } @parts;
+ push @parts, "FLAGS" if not grep { uc $_ eq "FLAGS" } @parts;
}
my @out;
More information about the Bps-public-commit
mailing list