[Bps-public-commit] r9345 - in Net-Server-IMAP: . lib/Net/Server/IMAP lib/Net/Server/IMAP/Command
alexmv at bestpractical.com
alexmv at bestpractical.com
Thu Oct 18 18:20:53 EDT 2007
Author: alexmv
Date: Thu Oct 18 18:20:50 2007
New Revision: 9345
Added:
Net-Server-IMAP/lib/Net/Server/IMAP/Command/Delete.pm
Net-Server-IMAP/lib/Net/Server/IMAP/Command/Rename.pm
Modified:
Net-Server-IMAP/ (props changed)
Net-Server-IMAP/lib/Net/Server/IMAP.pm
Net-Server-IMAP/lib/Net/Server/IMAP/Command/Create.pm
Net-Server-IMAP/lib/Net/Server/IMAP/Command/List.pm
Net-Server-IMAP/lib/Net/Server/IMAP/Command/Select.pm
Net-Server-IMAP/lib/Net/Server/IMAP/DefaultModel.pm
Net-Server-IMAP/lib/Net/Server/IMAP/Mailbox.pm
Log:
r23734 at zoq-fot-pik: chmrr | 2007-10-18 18:20:08 -0400
* DELETE and RENAME support
* root isn't the INBOX, it's above the INBOX
* Proper support of the CHILDREN extension
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 Thu Oct 18 18:20:50 2007
@@ -118,7 +118,7 @@
my $self = shift;
my ($connection) = @_;
- return "IMAP4rev1 STARTTLS AUTH=PLAIN";
+ return "IMAP4rev1 STARTTLS AUTH=PLAIN CHILDREN";
}
1; # Magic true value required at end of module
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 18:20:50 2007
@@ -8,15 +8,13 @@
sub validate {
my $self = shift;
- # TODO: ???
- return $self->no_command("Permission denied");
+ return $self->bad_command("Log in first") if $self->connection->is_unauth;
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) = @options;
- my $mailbox = $self->connection->model->lookup($name);
+ my $mailbox = $self->connection->model->lookup( @options );
return $self->no_command("Mailbox already exists") if $mailbox;
return 1;
@@ -26,9 +24,19 @@
my $self = shift;
my($name) = $self->parsed_options;
+ my @parts = $self->connection->model->split($name);
- my $root = $self->connection->model->root;
- $self->connection->model->add_child( $root, name => $name );
+ my $base = $self->connection->model->root;
+ for my $n (0.. $#parts) {
+ my $path = join($self->connection->model->root->seperator, @parts[0 .. $n]);
+ my $part = $self->connection->model->lookup($path);
+ unless ($part) {
+ unless ($part = $base->create( name => $parts[$n] )) {
+ return $self->no_command("Permission denied");
+ }
+ }
+ $base = $part;
+ }
$self->ok_completed();
}
Added: Net-Server-IMAP/lib/Net/Server/IMAP/Command/Delete.pm
==============================================================================
--- (empty file)
+++ Net-Server-IMAP/lib/Net/Server/IMAP/Command/Delete.pm Thu Oct 18 18:20:50 2007
@@ -0,0 +1,34 @@
+package Net::Server::IMAP::Command::Delete;
+
+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;
+
+ 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 doesn't exist") unless $mailbox;
+ return $self->no_command("Mailbox has children") if @{$mailbox->children};
+
+ return 1;
+}
+
+sub run {
+ my $self = shift;
+
+ my $mailbox = $self->connection->model->lookup($self->parsed_options);
+
+ $mailbox->delete or return $self->no_command("Permission denied");
+
+ $self->ok_completed();
+}
+
+1;
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 Thu Oct 18 18:20:50 2007
@@ -31,7 +31,7 @@
my $sep = $self->connection->model->root->seperator;
$search = quotemeta($search);
$search =~ s/\\\*/.*/g;
- $search =~ s/\\%/[^$sep]/g;
+ $search =~ s/\\%/[^$sep]+/g;
my $regex = qr{^\Q$root\E$search$};
$self->traverse( $self->connection->model->root, $regex );
}
@@ -44,13 +44,14 @@
my $node = shift;
my $regex = shift;
- my $str = $node->children ? q{(\HasChildren)} : q{()};
- $str .= q{ "/" };
+ my @props;
+ push @props, @{$node->children} ? \'\HasChildren' : \'\HasNoChildren';
+
+ my $str = $self->data_out(\@props);
+ $str .= q{ "} . $self->connection->model->root->seperator . q{" };
$str .= q{"} . $node->full_path . q{"};
- $self->tagged_response($str) if $node->full_path =~ $regex;
- if ( $node->children ) {
- $self->traverse( $_, $regex ) for @{ $node->children };
- }
+ $self->tagged_response($str) if $node->parent and $node->full_path =~ $regex;
+ $self->traverse( $_, $regex ) for @{ $node->children };
}
1;
Added: Net-Server-IMAP/lib/Net/Server/IMAP/Command/Rename.pm
==============================================================================
--- (empty file)
+++ Net-Server-IMAP/lib/Net/Server/IMAP/Command/Rename.pm Thu Oct 18 18:20:50 2007
@@ -0,0 +1,53 @@
+package Net::Server::IMAP::Command::Rename;
+
+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;
+
+ 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($old, $new) = @options;
+ my $oldbox = $self->connection->model->lookup($old);
+ return $self->no_command("Mailbox doesn't exist") unless $oldbox;
+ my $newbox = $self->connection->model->lookup($new);
+ return $self->no_command("Mailbox already exists") if $newbox;
+
+ return 1;
+}
+
+sub run {
+ my $self = shift;
+
+ my($old, $new) = $self->parsed_options;
+ my @parts = $self->connection->model->split($new);
+
+ my $newname = pop @parts;
+ my $mailbox = $self->connection->model->lookup($old);
+
+ my $base = $self->connection->model->root;
+ for my $n (0.. $#parts) {
+ my $path = join($self->connection->model->root->seperator, @parts[0 .. $n]);
+ my $part = $self->connection->model->lookup($path);
+ unless ($part) {
+ unless ($part = $base->create( name => $parts[$n] )) {
+ return $self->no_command("Permission denied");
+ }
+ }
+ $base = $part;
+ }
+
+ $mailbox->reparent($base) or return $self->no_command("Permission denied");
+ $mailbox->name($newname);
+
+ $self->ok_completed();
+}
+
+1;
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 Thu Oct 18 18:20:50 2007
@@ -20,7 +20,6 @@
return 1;
}
-
sub run {
my $self = shift;
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 Thu Oct 18 18:20:50 2007
@@ -22,25 +22,30 @@
if ( $roots{$user} ) {
$self->root( $roots{$user} );
} else {
- $self->root( $self->mailbox( name => "INBOX" ) );
- $self->root->add_child( name => $user );
+ $self->root( $self->mailbox() )
+ ->add_child( name => "INBOX", is_inbox => 1 )
+ ->add_child( name => $user );
$roots{$user} = $self->root;
}
return $self;
}
+sub split {
+ my $self = shift;
+ return grep {length} split quotemeta $self->root->seperator, shift;
+}
+
sub lookup {
my $self = shift;
my $name = shift;
- $name = "INBOX" if uc $name eq "INBOX";
- my @parts = split $self->root->seperator, $name;
- return undef unless @parts and shift @parts eq $self->root->name;
+ my @parts = $self->split($name);
my $part = $self->root;
+ return undef unless @parts;
while (@parts) {
- return undef unless $part->children;
+ return undef unless @{ $part->children };
my $find = shift @parts;
- my @match = grep { $_->name eq $find } @{ $part->children };
+ my @match = grep { $_->is_inbox ? uc $find eq "INBOX" : $_->name eq $find } @{ $part->children };
return undef unless @match;
$part = $match[0];
}
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 18:20:50 2007
@@ -7,7 +7,7 @@
use base 'Class::Accessor';
__PACKAGE__->mk_accessors(
- qw(name force_read_only parent children _path uidnext uids messages)
+ qw(name is_inbox force_read_only parent children _path uidnext uids messages)
);
sub new {
@@ -23,8 +23,10 @@
$self->uidnext(1000);
$self->messages( [] );
$self->uids( {} );
+ $self->children( [] );
my $name = $self->full_path;
+ return unless $name;
$name =~ s/\W+/_/g;
$name .= ".mailbox";
if ( -e $name ) {
@@ -89,17 +91,44 @@
my $self = shift;
my $node = ( ref $self )
->new( { @_, parent => $self } );
- $self->children( [] ) unless $self->children;
push @{ $self->children }, $node;
return $node;
}
-sub full_path {
+sub create {
+ my $self = shift;
+ return $self->add_child(@_);
+}
+
+sub reparent {
my $self = shift;
- return $self->_path if $self->_path;
+ my $parent = shift;
+
+ $self->parent->children([grep {$_ ne $self} @{$self->parent->children}]);
+ push @{$parent->children}, $self;
+ $self->parent($parent);
+ my @uncache = ($self);
+ while (@uncache) {
+ my $o = shift @uncache;
+ $o->_path(undef);
+ push @uncache, @{$o->children};
+ }
+ return 1;
+}
- return $self->name unless $self->parent;
+sub delete {
+ my $self = shift;
+ $self->parent->children([grep {$_ ne $self} @{$self->parent->children}]);
+
+ return 1;
+}
+
+sub full_path {
+ my $self = shift;
+ return $self->_path if defined $self->_path;
$self->_path(
+ !$self->parent ? "" :
+ !$self->parent->parent ? $self->name :
$self->parent->full_path . $self->seperator . $self->name );
return $self->_path;
}
More information about the Bps-public-commit
mailing list