[Bps-public-commit] r9344 - in Net-Server-IMAP: lib/Net/Server/IMAP lib/Net/Server/IMAP/Command
alexmv at bestpractical.com
alexmv at bestpractical.com
Thu Oct 18 15:27:29 EDT 2007
Author: alexmv
Date: Thu Oct 18 15:27:18 2007
New Revision: 9344
Added:
Net-Server-IMAP/lib/Net/Server/IMAP/Command/Copy.pm
Modified:
Net-Server-IMAP/ (props changed)
Net-Server-IMAP/lib/Net/Server/IMAP/Command/Append.pm
Net-Server-IMAP/lib/Net/Server/IMAP/Command/Create.pm
Net-Server-IMAP/lib/Net/Server/IMAP/Command/Store.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/Mailbox.pm
Net-Server-IMAP/lib/Net/Server/IMAP/Message.pm
Log:
r23732 at zoq-fot-pik: chmrr | 2007-10-18 15:26:33 -0400
* COPY and UID COPY support
* UID SEARCH support
* Use [TRYCREATE] on APPEND and COPY
* Store takes a what => arrayref, to be more like fetch
* Flush pending messages before changing selected mailbox
* 23423423423423:* still returns highest UID or ID
* Also support *:123 for UIDs and IDs
Modified: Net-Server-IMAP/lib/Net/Server/IMAP/Command/Append.pm
==============================================================================
--- Net-Server-IMAP/lib/Net/Server/IMAP/Command/Append.pm (original)
+++ Net-Server-IMAP/lib/Net/Server/IMAP/Command/Append.pm Thu Oct 18 15:27:18 2007
@@ -15,7 +15,8 @@
return $self->bad_command("Too many options") if @options > 4;
my $mailbox = $self->connection->model->lookup( $options[0] );
- return $self->no_command("Mailbox does not exist") unless $mailbox;
+ return $self->no_command("[TRYCREATE] Mailbox does not exist") unless $mailbox;
+ return $self->bad_command("Mailbox is read-only") if $mailbox->read_only;
return 1;
}
Added: Net-Server-IMAP/lib/Net/Server/IMAP/Command/Copy.pm
==============================================================================
--- (empty file)
+++ Net-Server-IMAP/lib/Net/Server/IMAP/Command/Copy.pm Thu Oct 18 15:27:18 2007
@@ -0,0 +1,41 @@
+package Net::Server::IMAP::Command::Close;
+
+use warnings;
+use strict;
+
+use base qw/Net::Server::IMAP::Command/;
+
+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("Not enough options") if @options < 2;
+ return $self->bad_command("Too many options") if @options > 2;
+
+ my $mailbox = $self->connection->model->lookup( $options[1] );
+ return $self->no_command("[TRYCREATE] Mailbox does not exist") unless $mailbox;
+ return $self->bad_command("Mailbox is read-only") if $mailbox->read_only;
+
+ return 1;
+}
+
+sub run {
+ my $self = shift;
+
+ my ( $messages, $name ) = $self->parsed_options;
+ my @messages = $self->connection->get_messages($messages);
+
+ my $mailbox = $self->connection->model->lookup( $name );
+
+ return $self->no_command("Permission denied") if grep {not $_->copy_allowed($mailbox)} @messages;
+
+ $_->copy($mailbox) for @messages;
+
+ $self->ok_completed();
+}
+
+1;
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 Thu Oct 18 15:27:18 2007
@@ -25,7 +25,7 @@
sub run {
my $self = shift;
- my($name) = @options;
+ my($name) = $self->parsed_options;
my $root = $self->connection->model->root;
$self->connection->model->add_child( $root, name => $name );
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 Thu Oct 18 15:27:18 2007
@@ -24,13 +24,11 @@
sub run {
my $self = shift;
- my ( $messages, $what, @flags ) = $self->parsed_options;
- @flags = map {ref $_ ? @{$_} : $_} @flags;
+ my ( $messages, $what, $flags ) = $self->parsed_options;
+ $flags = ref $flags ? $flags : [$flags];
my @messages = $self->connection->get_messages($messages);
$self->connection->ignore_flags(1) if $what =~ /\.SILENT$/i;
- for my $m (@messages) {
- $m->store( $what => @flags );
- }
+ $_->store( $what => $flags ) for @messages;
$self->connection->ignore_flags(0) if $what =~ /\.SILENT$/i;
$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 Thu Oct 18 15:27:18 2007
@@ -1,9 +1,14 @@
package Net::Server::IMAP::Command::Uid;
+
+use warnings;
+use strict;
+
use base qw/Net::Server::IMAP::Command/;
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;
@@ -22,7 +27,7 @@
$self->$subcommand(@rest);
} else {
$self->log(
- $self->options . " wasn't understood by the 'UID' command" );
+ $subcommand . " wasn't understood by the 'UID' command" );
$self->no_failed(
alert => q{Your client sent a UID command we didn't understand} );
}
@@ -32,6 +37,9 @@
sub fetch {
my $self = shift;
+ return $self->bad_command("Not enough options") if @_ < 2;
+ return $self->bad_command("Too many options") if @_ > 2;
+
my ( $messages, $spec ) = @_;
$spec = [$spec] unless ref $spec;
push @{$spec}, "UID" unless grep {uc $_ eq "UID"} @{$spec};
@@ -50,12 +58,15 @@
return $self->bad_command("Mailbox is read-only") if $self->connection->selected->read_only;
- my ( $messages, $what, @flags ) = @_;
- @flags = map {ref $_ ? @{$_} : $_} @flags;
+ return $self->bad_command("Not enough options") if @_ < 3;
+ return $self->bad_command("Too many options") if @_ > 3;
+
+ my ( $messages, $what, $flags ) = @_;
+ $flags = ref $flags ? $flags : [$flags];
my @messages = $self->connection->selected->get_uids($messages);
$self->connection->ignore_flags(1) if $what =~ /\.SILENT$/i;
for my $m (@messages) {
- $m->store( $what => @flags );
+ $m->store( $what => $flags );
$self->connection->untagged_fetch->{$self->connection->sequence($m)}{UID}++
unless $what =~ /\.SILENT$/i;
}
@@ -66,16 +77,32 @@
sub copy {
my $self = shift;
- my $args = shift;
- $self->no_unimplemented();
- $self->ok_completed;
+
+ return $self->bad_command("Not enough options") if @_ < 2;
+ return $self->bad_command("Too many options") if @_ > 2;
+
+ my ( $messages, $name ) = @_;
+ my $mailbox = $self->connection->model->lookup( $name );
+ return $self->no_command("[TRYCREATE] Mailbox does not exist") unless $mailbox;
+ return $self->bad_command("Mailbox is read-only") if $mailbox->read_only;
+
+ my @messages = $self->connection->selected->get_uids($messages);
+ return $self->no_command("Permission denied") if grep {not $_->copy_allowed($mailbox)} @messages;
+
+ $_->copy($mailbox) for @messages;
+ $self->ok_completed;
}
sub search {
my $self = shift;
- my $args = shift;
- $self->no_unimplemented();
+
+ my $filter = Net::Server::IMAP::Command::Search::filter($self, @_);
+ return unless $filter;
+
+ my @results = map {$_->uid} grep {$filter->($_)} $self->connection->get_messages('1:*');
+ $self->untagged_response("SEARCH @results");
+
$self->ok_completed;
}
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 Thu Oct 18 15:27:18 2007
@@ -7,7 +7,7 @@
use Net::Server::IMAP::Command;
-__PACKAGE__->mk_accessors(qw(server io_handle selected model pending temporary_messages temporary_sequence_map previous_exists untagged_expunge untagged_fetch ignore_flags));
+__PACKAGE__->mk_accessors(qw(server io_handle _selected model pending temporary_messages temporary_sequence_map previous_exists untagged_expunge untagged_fetch ignore_flags));
sub new {
my $class = shift;
@@ -31,7 +31,7 @@
return;
}
- $self->log("C: $content");
+ $self->log("C(@{[$self->io_handle->peerport]}): $content");
if ( $self->pending ) {
$self->pending->($content);
@@ -61,7 +61,7 @@
sub close {
my $self = shift;
- $self->server->connections->{ $self->io_handle } = undef;
+ delete $self->server->connections->{ $self->io_handle->fileno };
$self->server->select->remove( $self->io_handle );
$self->io_handle->close;
}
@@ -117,6 +117,12 @@
return $self->{auth};
}
+sub selected {
+ my $self = shift;
+ $self->send_untagged if @_ and $self->selected;
+ return $self->_selected(@_);
+}
+
sub untagged_response {
my $self = shift;
while ( my $message = shift ) {
@@ -157,7 +163,6 @@
my $now = @{$self->temporary_messages || $self->selected->messages};
$self->untagged_response( $now . ' EXISTS' ) if $expected != $now;
$self->previous_exists($now);
-
}
sub get_messages {
@@ -166,17 +171,18 @@
my $messages = $self->temporary_messages || $self->selected->messages;
- my @ids;
+ my %ids;
for ( split ',', $str ) {
if (/^(\d+):(\d+)$/) {
- push @ids, $1 .. $2;
- } elsif (/^(\d+):\*$/) {
- push @ids, $1 .. @{ $messages } + 0;
+ $ids{$_}++ for $2 > $1 ? $1 .. $2 : $2 .. $1;
+ } elsif (/^(\d+):\*$/ or /^\*:(\d+)$/) {
+ $ids{$_}++ for @{ $messages } + 0, $1 .. @{ $messages } + 0;
} elsif (/^(\d+)$/) {
- push @ids, $1;
+ $ids{$1}++;
}
}
- return grep {defined} map { $messages->[ $_ - 1 ] } @ids;
+ return
+ grep {defined} map { $messages->[ $_ - 1 ] } sort {$a <=> $b} keys %ids;
}
sub sequence {
@@ -201,9 +207,10 @@
if ($self->io_handle) {
$self->io_handle->print($msg);
- $self->log("S: $msg");
+ $self->log("S(@{[$self->io_handle->peerport]}): $msg");
} else {
warn "Connection closed unexpectedly\n";
+ $self->close;
}
}
Modified: Net-Server-IMAP/lib/Net/Server/IMAP/Mailbox.pm
==============================================================================
--- Net-Server-IMAP/lib/Net/Server/IMAP/Mailbox.pm (original)
+++ Net-Server-IMAP/lib/Net/Server/IMAP/Mailbox.pm Thu Oct 18 15:27:18 2007
@@ -71,18 +71,18 @@
my $self = shift;
my $str = shift;
- my @ids;
+ my %ids;
for ( split ',', $str ) {
if (/^(\d+):(\d+)$/) {
- push @ids, $1 .. $2;
- } elsif (/^(\d+):\*$/) {
- push @ids, $1 .. $self->uidnext;
+ $ids{$_}++ for $2 > $1 ? $1 .. $2 : $2 .. $1;
+ } elsif (/^(\d+):\*$/ or /^\*:(\d+)$/) {
+ $ids{$_}++ for $self->uidnext - 1, $1 .. $self->uidnext - 1;
} elsif (/^(\d+)$/) {
- push @ids, $1;
+ $ids{$1}++;
}
}
return
- grep {defined} map { $self->uids->{$_} } @ids;
+ grep {defined} map { $self->uids->{$_} } sort {$a <=> $b} keys %ids;
}
sub add_child {
@@ -118,7 +118,7 @@
sub recent {
my $self = shift;
- return 0;
+ return scalar grep {$_->has_flag('\Recent')} @{$self->messages};
}
sub unseen {
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 Thu Oct 18 15:27:18 2007
@@ -26,6 +26,27 @@
sub expunge {
}
+sub copy_allowed {
+ return 1;
+}
+
+sub copy {
+ my $self = shift;
+ my $mailbox = shift;
+
+ my $clone = bless {}, ref $self;
+ $clone->mime( $self->mime ); # This leads to sharing the same MIME
+ # object, but since they're
+ # immutable, I don't think we care
+ $clone->internaldate( $self->internaldate ); # Ditto for the date
+ $clone->_flags( {} );
+ $clone->set_flag( $_, 1 ) for ('\Recent', $self->flags);
+
+ $mailbox->add_message($clone);
+
+ return $clone;
+}
+
sub set_flag {
my $self = shift;
my $flag = shift;
@@ -292,7 +313,8 @@
sub store {
my $self = shift;
- my ( $what, @flags ) = @_;
+ my ( $what, $flags ) = @_;
+ my @flags = @{$flags};
if ( $what =~ /^-/ ) {
$self->clear_flag($_) for grep { $self->has_flag($_) } @flags;
} elsif ( $what =~ /^\+/ ) {
More information about the Bps-public-commit
mailing list