[Bps-public-commit] r10599 - in Net-IMAP-Server: lib/Net/IMAP lib/Net/IMAP/Server lib/Net/IMAP/Server/Command
alexmv at bestpractical.com
alexmv at bestpractical.com
Wed Jan 30 17:16:59 EST 2008
Author: alexmv
Date: Wed Jan 30 17:16:59 2008
New Revision: 10599
Modified:
Net-IMAP-Server/ (props changed)
Net-IMAP-Server/lib/Net/IMAP/Server.pm
Net-IMAP-Server/lib/Net/IMAP/Server/Command.pm
Net-IMAP-Server/lib/Net/IMAP/Server/Command/Authenticate.pm
Net-IMAP-Server/lib/Net/IMAP/Server/Connection.pm
Net-IMAP-Server/lib/Net/IMAP/Server/DefaultAuth.pm
Net-IMAP-Server/lib/Net/IMAP/Server/DefaultModel.pm
Net-IMAP-Server/lib/Net/IMAP/Server/Mailbox.pm
Net-IMAP-Server/lib/Net/IMAP/Server/Message.pm
Log:
r27353 at zoq-fot-pik: chmrr | 2008-01-30 17:16:09 -0500
* Perltidy
* POD for all but the commands
* Auth now lists SASL options, instead of feeing them to a function
* Removed a few unused and unneeded methods
* ->out always appends newline now
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 Wed Jan 30 17:16:59 2008
@@ -6,15 +6,9 @@
use base qw/Net::Server::Coro Class::Accessor/;
use UNIVERSAL::require;
-use Module::Refresh; # for development
-use Carp;
use Coro;
-use Net::IMAP::Server::Mailbox;
-use Net::IMAP::Server::Connection;
-
-our $VERSION = '0.001';
-
+our $VERSION = '0.1';
=head1 NAME
@@ -29,6 +23,8 @@
ssl_port => 993,
auth_class => "Your::Auth::Class",
model_class => "Your::Model::Class",
+ user => "nobody",
+ group => "nobody",
)->run;
=head1 DESCRIPTION
@@ -51,14 +47,16 @@
L<Net::IMAP::Server::DefaultModel> and
L<Net::IMAP::Server::DefaultAuth>. This allows you to back your
messages from arbitrary data sources, or provide your own
-authorization backend.
+authorization backend. For the most part, the implementation of the
+IMAP components should be opaque.
=head1 METHODS
=cut
__PACKAGE__->mk_accessors(
- qw/connections port ssl_port auth_class model_class user group poll_every/);
+ qw/connections port ssl_port auth_class model_class connection_class user group poll_every/
+);
=head2 new PARAMHASH
@@ -71,7 +69,7 @@
=item port
-The port to bind to. Defaults to port 4242.
+The port to bind to. Defaults to port 1430.
=item ssl_port
@@ -88,6 +86,11 @@
The name of the class which implements the model backend. This must
be a subclass of L<Net::IMAP::Server::DefaultModel>.
+=item connection_class
+
+On rare occasions, you may wish to subclass the connection class; this
+class must be a subclass of L<Net::IMAP::Server::Connection>.
+
=item user
The name or ID of the user that the server should run as; this
@@ -96,22 +99,35 @@
privileges should not be needed. Running as your C<nobody> user or
equivilent is suggested.
+=item group
+
+The name or ID of the group that the server should run as; see
+C<user>, above.
+
+=item poll_every
+
+How often the current mailbox should be polled, in seconds; defaults
+to 0, which means it will be polled after every client command.
+
=back
=cut
sub new {
my $class = shift;
- unless (-r "certs/server-cert.pem" and -r "certs/server-key.pem") {
- die "Can't read certs (certs/server-cert.pem and certs/server-key.pem)\n";
+ unless ( -r "certs/server-cert.pem" and -r "certs/server-key.pem" ) {
+ die
+ "Can't read certs (certs/server-cert.pem and certs/server-key.pem)\n";
}
- my $self = Class::Accessor::new($class,
- { port => 8080,
- ssl_port => 0,
- auth_class => "Net::IMAP::Server::DefaultAuth",
- model_class => "Net::IMAP::Server::DefaultModel",
- poll_every => 0,
+ my $self = Class::Accessor::new(
+ $class,
+ { port => 1430,
+ ssl_port => 0,
+ auth_class => "Net::IMAP::Server::DefaultAuth",
+ model_class => "Net::IMAP::Server::DefaultModel",
+ connection_class => "Net::IMAP::Server::Connection",
+ poll_every => 0,
@_,
connections => [],
}
@@ -119,23 +135,41 @@
UNIVERSAL::require( $self->auth_class )
or die "Can't require auth class: $@\n";
$self->auth_class->isa("Net::IMAP::Server::DefaultAuth")
- or die "Auth class (@{[$self->auth_class]}) doesn't inherit from Net::IMAP::Server::DefaultAuth\n";
+ or die
+ "Auth class (@{[$self->auth_class]}) doesn't inherit from Net::IMAP::Server::DefaultAuth\n";
UNIVERSAL::require( $self->model_class )
or die "Can't require model class: $@\n";
$self->model_class->isa("Net::IMAP::Server::DefaultModel")
- or die "Auth class (@{[$self->model_class]}) doesn't inherit from Net::IMAP::Server::DefaultModel\n";
+ or die
+ "Model class (@{[$self->model_class]}) doesn't inherit from Net::IMAP::Server::DefaultModel\n";
+
+ UNIVERSAL::require( $self->connection_class )
+ or die "Can't require connection class: $@\n";
+ $self->connection_class->isa("Net::IMAP::Server::Connection")
+ or die
+ "Connection class (@{[$self->connection_class]}) doesn't inherit from Net::IMAP::Server::Connection\n";
return $self;
}
+=head2 run
+
+Starts the server; this method shouldn't be expected to return.
+Within this method, C<$Net::IMAP::Server::Server> is set to the object
+that this was called on; thus, all IMAP objecst have a way of
+referring to the server -- and though L</connection>, L</auth>, and
+L</model>, whatever parts of the IMAP internals they need.
+
+=cut
+
sub run {
- my $self = shift;
+ my $self = shift;
my @proto = qw/TCP/;
my @port = $self->port;
- if ($self->ssl_port) {
+ if ( $self->ssl_port ) {
push @proto, "SSL";
- push @port, $self->ssl_port;
+ push @port, $self->ssl_port;
}
local $Net::IMAP::Server::Server = $self;
$self->SUPER::run(
@@ -146,76 +180,150 @@
);
}
+=head2 process_request
+
+Accepts a client connection.
+
+=cut
+
sub process_request {
- my $self = shift;
+ my $self = shift;
my $handle = $self->{server}{client};
- my $conn = Net::IMAP::Server::Connection->new(
+ my $conn = $self->connection_class->new(
io_handle => $handle,
server => $self,
);
$Coro::current->prio(-4);
- push @{$self->connections}, $conn;
+ push @{ $self->connections }, $conn;
$conn->handle_lines;
}
+=head2 DESTROY
+
+On destruction, ensure that we close all client connections and
+listening sockets.
+
+=cut
+
DESTROY {
my $self = shift;
$_->close for grep { defined $_ } @{ $self->connections };
$self->socket->close if $self->socket;
}
+=head2 connections
+
+Returns an arrayref of L<Net::IMAP::Server::Connection> objects which
+are currently connected to the server.
+
+=cut
+
+=head2 connection
+
+Returns the currently active L<Net::IMAP::Server::Connection> object,
+if there is one.
+
+=cut
+
sub connection {
my $self = shift;
return $self->{connection};
}
+=head2 auth
+
+Returns the current L<Net::IMAP::Server::DefaultAuth> (or, more
+probably, descendant thereof) for the active connection.
+
+=cut
+
sub auth {
my $self = shift;
return $self->{auth};
}
+=head2 auth
+
+Returns the current L<Net::IMAP::Server::DefaultModel> (or, more
+probably, descendant thereof) for the active connection.
+
+=cut
+
sub model {
my $self = shift;
return $self->{model};
}
+=head2 concurrent_mailbox_connections [MAILBOX]
+
+This can be called as either a class method or an instance method; it
+returns the set of connections which are concurrently connected to the
+given mailbox object (which defaults to the current connection's
+selected mailbox)
+
+=cut
+
sub concurrent_mailbox_connections {
- my $class = shift;
- my $self = ref $class ? $class : $Net::IMAP::Server::Server;
+ my $class = shift;
+ my $self = ref $class ? $class : $Net::IMAP::Server::Server;
my $selected = shift || $self->connection->selected;
return () unless $selected;
- return grep {$_->is_auth and $_->is_selected
- and $_->selected eq $selected} @{$self->connections};
+ return
+ grep { $_->is_auth and $_->is_selected and $_->selected eq $selected }
+ @{ $self->connections };
}
+=head2 concurrent_user_connections [USER]
+
+This can be called as either a class method or an instance method; it
+returns the set of connections whose
+L<Net::IMAP::Server::DefaultAuth/user> is the same as the given
+L<USER> (which defaults to the current connection's user)
+
+=cut
+
sub concurrent_user_connections {
my $class = shift;
- my $self = ref $class ? $class : $Net::IMAP::Server::Server;
- my $user = shift || $self->connection->auth->user;
+ my $self = ref $class ? $class : $Net::IMAP::Server::Server;
+ my $user = shift || $self->connection->auth->user;
return () unless $user;
- return grep {$_->is_auth
- and $_->auth->user eq $user} @{$self->connections};
+ return
+ grep { $_->is_auth and $_->auth->user eq $user }
+ @{ $self->connections };
}
+=head2 capability
+
+Returns the C<CAPABILITY> string for the server. This string my be
+modified by the connection before being sent to the client (see
+L<Net::IMAP::Server::Connection/capability>).
+
+=cut
+
sub capability {
my $self = shift;
- return "IMAP4rev1 STARTTLS AUTH=PLAIN CHILDREN LITERAL+ UIDPLUS ID";
+ return "IMAP4rev1 STARTTLS CHILDREN LITERAL+ UIDPLUS ID";
}
+=head2 id
+
+Returns a hash of properties to be conveyed to the client, should they
+ask the server's identity.
+
+=cut
+
sub id {
return (
- name => "Net-IMAP-Server",
- version => $Net::IMAP::Server::VERSION,
- );
+ name => "Net-IMAP-Server",
+ version => $Net::IMAP::Server::VERSION,
+ );
}
1; # Magic true value required at end of module
__END__
-
-
=head1 DEPENDENCIES
L<Coro>, L<Net::Server::Coro>
Modified: Net-IMAP-Server/lib/Net/IMAP/Server/Command.pm
==============================================================================
--- Net-IMAP-Server/lib/Net/IMAP/Server/Command.pm (original)
+++ Net-IMAP-Server/lib/Net/IMAP/Server/Command.pm Wed Jan 30 17:16:59 2008
@@ -6,71 +6,151 @@
use base 'Class::Accessor';
use Regexp::Common qw/delimited/;
-__PACKAGE__->mk_accessors(qw(server connection command_id options_str command _parsed_options _literals _pending_literal));
+__PACKAGE__->mk_accessors(
+ qw(server connection command_id options_str command _parsed_options _literals _pending_literal)
+);
+
+=head1 NAME
+
+Net::IMAP::Server::Command - A command in the IMAP server
+
+=head1 DESCRIPTION
+
+Commands the IMAP server knows about should be subclasses of this.
+They will want to override the L</validate> and L</run> methods.
+
+=head1 METHODS
+
+=head2 new
+
+Called by the connection to create a new command.
+
+=cut
sub new {
my $class = shift;
- my $self = $class->SUPER::new(@_);
- $self->_parsed_options([]);
- $self->_literals([]);
+ my $self = $class->SUPER::new(@_);
+ $self->_parsed_options( [] );
+ $self->_literals( [] );
return $self;
}
+=head2 server
+
+Gets or sets the L<Net::IMAP::Server> associated with this command.
+
+=cut
+
+=head2 connection
+
+Gets or sets the L<Net::IMAP::Server::Connection> associated with this
+command.
+
+=cut
+
+=head2 validate
+
+Called before the command is run. If it returns a false value, the
+command is not run; it will probably want to inspect
+L</parsed_options>. If C<validate> returns a false value, it is
+responsible for calling L</no_command> or L</bad_command> to notify
+the client of the failure. Handily, these return a false value.
+
+=cut
+
sub validate {
return 1;
}
+=head2 run
+
+Does the guts of the command. The return value is ignored; the
+command is in charge of eventually sending one of L</ok_command>,
+L</bad_command>, or L</no_command> to the client.
+
+The default implementation simply always response with
+L</bad_command>.
+
+=cut
+
sub run {
my $self = shift;
$self->bad_command( "command '" . $self->command . "' not recognized" );
}
+=head2 has_literal
+
+Analyzes the options line, and returns true if the line has literals
+(as defined in the FRC, a literal is of the form C<{42}>). If the
+line has literals, installs a L<Net::IMAP::Server::Connection/pending>
+callback to continue the parsing, and returns true.
+
+=cut
+
sub has_literal {
my $self = shift;
- unless ($self->options_str =~ /\{(\d+)(\+)?\}[\r\n]*$/) {
+ unless ( $self->options_str =~ /\{(\d+)(\+)?\}[\r\n]*$/ ) {
$self->parse_options;
return;
}
my $options = $self->options_str;
- my $next = $#{$self->_literals} + 1;
+ my $next = $#{ $self->_literals } + 1;
$options =~ s/\{(\d+)(\+)?\}[\r\n]*$/{{$next}}/;
$self->_pending_literal($1);
$self->options_str($options);
# Pending
- $self->connection->pending(sub {
- my $content = shift;
- if (length $content <= $self->_pending_literal) {
- $self->_literals->[$next] .= $content;
- $self->_pending_literal( $self->_pending_literal - length $content);
- } else {
- $self->_literals->[$next] .= substr($content, 0, $self->_pending_literal, "");
- $self->connection->pending(undef);
- $self->options_str($self->options_str . $content);
- return if $self->has_literal;
- $self->run if $self->validate;
+ $self->connection->pending(
+ sub {
+ my $content = shift;
+ if ( length $content <= $self->_pending_literal ) {
+ $self->_literals->[$next] .= $content;
+ $self->_pending_literal(
+ $self->_pending_literal - length $content );
+ } else {
+ $self->_literals->[$next]
+ .= substr( $content, 0, $self->_pending_literal, "" );
+ $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" ) unless $2;
+ );
+ $self->out("+ Continue") unless $2;
return 1;
}
+=head2 parse_options
+
+Parses the options, and puts the results (which may be a data
+structure) into L<parsed_options>.
+
+=cut
+
sub parse_options {
my $self = shift;
- my $str = shift;
+ my $str = shift;
- return $self->_parsed_options if not defined $str and not defined $self->options_str;
+ 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+$RE{balanced}{-parens=>'()[]<>'}|\S+)/, defined $str ? $str : $self->options_str) {
- if ($term =~ /^$RE{delimited}{-delim=>'"'}{-keep}$/) {
+ for my $term (
+ grep {/\S/}
+ split
+ /($RE{delimited}{-delim=>'"'}|$RE{balanced}{-parens=>'()'}|\S+$RE{balanced}{-parens=>'()[]<>'}|\S+)/,
+ defined $str ? $str : $self->options_str
+ )
+ {
+ if ( $term =~ /^$RE{delimited}{-delim=>'"'}{-keep}$/ ) {
push @parsed, $3;
- } elsif ($term =~ /^$RE{balanced}{-parens=>'()'}$/) {
+ } elsif ( $term =~ /^$RE{balanced}{-parens=>'()'}$/ ) {
$term =~ s/^\((.*)\)$/$1/;
- push @parsed, [$self->parse_options($term)];
- } elsif ($term =~ /^\{\{(\d+)\}\}$/) {
+ push @parsed, [ $self->parse_options($term) ];
+ } elsif ( $term =~ /^\{\{(\d+)\}\}$/ ) {
push @parsed, $self->_literals->[$1];
} else {
push @parsed, $term;
@@ -79,14 +159,73 @@
return @parsed if defined $str;
$self->options_str(undef);
- $self->_parsed_options([@{$self->_parsed_options}, @parsed]);
+ $self->_parsed_options( [ @{ $self->_parsed_options }, @parsed ] );
}
+=head2 command_id
+
+Returns the (arbitrary) string that the client identified the command with.
+
+=cut
+
+=head2 parsed_options
+
+Returns the list of options to the command.
+
+=cut
+
sub parsed_options {
my $self = shift;
- return @{$self->_parsed_options(@_)};
+ return @{ $self->_parsed_options(@_) };
}
+=head2 options_str
+
+Returns the flat string represetnation of the options the client gave.
+
+=cut
+
+=head2 data_out DATA
+
+Returns a string representing the most probable IMAP string that
+conveys the C<DATA>.
+
+=over
+
+=item *
+
+Array references are converted into "paranthesized lists," and each
+element is recursively output.
+
+=item *
+
+Scalar references are dereferenced and returned as-is.
+
+=item *
+
+C<undef> is output as C<NIL>.
+
+=item *
+
+Scalar values containing special characters are output as literals
+
+=item *
+
+Purely numerical scalra values are output with no change
+
+=item *
+
+All other scalar values are ouput within quotes.
+
+=back
+
+Since the IMAP specification contains nothing which is similar to a
+hash, hash references are treated specially; specifically, the C<type>
+key is taken to be how the C<value> key should be output. Options for
+C<type> are C<string> or C<literal>.
+
+=cut
+
sub data_out {
my $self = shift;
my $data = shift;
@@ -94,15 +233,15 @@
return "(" . join( " ", map { $self->data_out($_) } @{$data} ) . ")";
} elsif ( ref $data eq "SCALAR" ) {
return $$data;
- } elsif ( ref $data eq "HASH") {
- if ($data->{type} eq "string") {
+ } elsif ( ref $data eq "HASH" ) {
+ if ( $data->{type} eq "string" ) {
if ( $data =~ /[{"\r\n%*\\\[]/ ) {
- return "{" . ( length($data->{value}) ) . "}\r\n$data";
+ return "{" . ( length( $data->{value} ) ) . "}\r\n$data";
} else {
- return '"' . $data->{value} .'"';
+ return '"' . $data->{value} . '"';
}
- } elsif ($data->{type} eq "literal") {
- return "{" . ( length($data->{value}) ) . "}\r\n$data";
+ } elsif ( $data->{type} eq "literal" ) {
+ return "{" . ( length( $data->{value} ) ) . "}\r\n$data";
}
} elsif ( not ref $data ) {
if ( not defined $data ) {
@@ -118,25 +257,60 @@
return "";
}
+=head2 untagged_response STRING
+
+Sends an untagged response to the client.
+
+=cut
+
sub untagged_response {
my $self = shift;
$self->connection->untagged_response(@_);
}
+=head2 tagged_response
+
+Sends a tagged response to the client.
+
+=cut
+
sub tagged_response {
my $self = shift;
- while ( my $message = shift ) {
- next unless $message;
- $self->untagged_response( uc( $self->command ) . " " . $message );
- }
+ $self->untagged_response( uc( $self->command ) . " $_" )
+ for grep defined, @_;
}
+=head2 poll_after
+
+Returns a true value if the command should send untagged updates abou
+tthe selected mailbox after the command completes. Defaults to always
+true.
+
+=cut
+
+sub poll_after {1}
+
+=head2 send_untagged
+
+Sends untagged updates about the currently selected inbox to the
+client using L<Net::IMAP::Server::Connection/send_untagged>, but only
+if the command has a true L</poll_after>.
+
+=cut
+
sub send_untagged {
my $self = shift;
-
- $self->connection->send_untagged( @_ ) if $self->poll_after;
+ $self->connection->send_untagged(@_) if $self->poll_after;
}
+=head2 ok_command MESSAGE [, RESPONSECODE => STRING, ...]
+
+Sends untagged OK responses for any C<RESPONSECODE> pairs, then
+outputs untagged messages via L</send_untagged>, then sends a tagged
+OK with the given C<MESSAGE>.
+
+=cut
+
sub ok_command {
my $self = shift;
my $message = shift;
@@ -146,10 +320,31 @@
"OK [" . uc($_) . "] " . $extra_responses{$_} );
}
$self->send_untagged;
- $self->out( $self->command_id . " " . "OK " . $message . "\r\n" );
+ $self->out( $self->command_id . " OK $message" );
return 1;
}
+=head2 ok_completed [RESPONSECODE => STRING]
+
+Sends an C<OK COMPLETED> tagged response to the client.
+
+=cut
+
+sub ok_completed {
+ my $self = shift;
+ my %extra_responses = (@_);
+ $self->ok_command( uc( $self->command ) . " COMPLETED",
+ %extra_responses );
+}
+
+=head2 ok_command MESSAGE [, RESPONSECODE => STRING, ...]
+
+Sends untagged NO responses for any C<RESPONSECODE> pairs, then
+outputs untagged messages via L</send_untagged>, then sends a tagged
+OK with the given C<MESSAGE>.
+
+=cut
+
sub no_command {
my $self = shift;
my $message = shift;
@@ -158,46 +353,45 @@
$self->untagged_response(
"NO [" . uc($_) . "] " . $extra_responses{$_} );
}
- $self->out( $self->command_id . " " . "NO " . $message . "\r\n" );
+ $self->out( $self->command_id . " NO $message" );
return 0;
}
-sub no_failed {
- my $self = shift;
- my %extra_responses = (@_);
- $self->no_command( uc( $self->command ) . " FAILED", %extra_responses );
-}
+=head2 bad_command REASON
-sub no_unimplemented {
- my $self = shift;
- $self->no_failed( alert => "Feature unimplemented. sorry. We'd love patches!" );
-}
+Sends any untagged updates to the client using L</send_untagged>, then
+sents a tagged C<BAD> response with the given C<REASON>.
-sub ok_completed {
- my $self = shift;
- my %extra_responses = (@_);
- $self->ok_command( uc( $self->command ) . " COMPLETED",
- %extra_responses );
-}
+=cut
sub bad_command {
my $self = shift;
my $reason = shift;
$self->send_untagged;
- $self->out( $self->command_id . " " . "BAD " . $reason . "\r\n" );
+ $self->out( $self->command_id . " BAD $reason" );
return 0;
}
+=head2 log MESSAGE
+
+Identical to L<Net::IMAP::Server::Connection/log>.
+
+=cut
+
sub log {
my $self = shift;
$self->connection->log(@_);
}
+=head2 out MESSAGE
+
+Identical to L<Net::IMAP::Server::Connection/out>.
+
+=cut
+
sub out {
my $self = shift;
$self->connection->out(@_);
}
-sub poll_after { 1 }
-
1;
Modified: Net-IMAP-Server/lib/Net/IMAP/Server/Command/Authenticate.pm
==============================================================================
--- Net-IMAP-Server/lib/Net/IMAP/Server/Command/Authenticate.pm (original)
+++ Net-IMAP-Server/lib/Net/IMAP/Server/Command/Authenticate.pm Wed Jan 30 17:16:59 2008
@@ -30,9 +30,10 @@
my($type, $arg) = $self->parsed_options;
$self->server->auth_class->require || warn $@;
my $auth = $self->server->auth_class->new;
- if ( $auth->provides_sasl( uc $type ) ) {
+ if ( grep {uc $type eq uc $_} $auth->sasl_provides ) {
$type = lc $type;
- $self->sasl( $auth->$type() );
+ my $function = "sasl_$type";
+ $self->sasl( $auth->$function() );
$self->pending_auth($auth);
$self->connection->pending(sub {$self->continue(@_)});
$self->continue( $arg || "");
@@ -55,7 +56,7 @@
my $response = $self->sasl->($line);
if ( ref $response ) {
- $self->out( "+ " . encode_base64($$response) . "\r\n" );
+ $self->out( "+ " . encode_base64($$response) );
} elsif ($response) {
$self->connection->pending(undef);
$self->connection->auth( $self->pending_auth );
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 Wed Jan 30 17:16:59 2008
@@ -5,43 +5,149 @@
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 last_poll));
+use Net::IMAP::Server::Command;
+
+__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 last_poll)
+);
+
+=head1 NAME
+
+Net::IMAP::Server::Connection - Connection to a client
+
+=head1 DESCRIPTION
+
+Maintains all of the state for a client connection to the IMAP server.
+
+=head1 METHODS
+
+=head2 new
+
+Creates a new connection; the server will take care of this step.
+
+=cut
sub new {
my $class = shift;
- my $self = $class->SUPER::new( { @_, state => "unauth", untagged_expunge => [], untagged_fetch => {}, last_poll => time } );
+ my $self = $class->SUPER::new(
+ { @_,
+ state => "unauth",
+ untagged_expunge => [],
+ untagged_fetch => {},
+ last_poll => time
+ }
+ );
$self->greeting;
return $self;
}
+=head2 server
+
+Returns the L<Net::IMAP::Server> that this connection is on.
+
+=head2 io_handle
+
+Returns the IO handle that can be used to read from or write to the
+client.
+
+=head2 model
+
+Gets or sets the L<Net::IMAP::Server::DefaultModel> or descendant
+associated with this connection. Note that connections which have not
+authenticated yet do not have a model.
+
+=head2 auth
+
+Gets or sets the L<Net::IMAP::Server::DefaultAuth> or descendant
+associated with this connection. Note that connections which have not
+authenticated yet do not have an auth object.
+
+=cut
+
+sub auth {
+ my $self = shift;
+ if (@_) {
+ $self->{auth} = shift;
+ $self->server->{auth} = $self->{auth};
+ $self->server->model_class->require || warn $@;
+ $self->model(
+ $self->server->model_class->new( { auth => $self->{auth} } ) );
+ }
+ return $self->{auth};
+}
+
+=head2 selected [MAILBOX]
+
+Gets or sets the currently selected mailbox for this connection. This
+may trigger the sending of untagged notifications to the client.
+
+=cut
+
+sub selected {
+ my $self = shift;
+ if ( @_ and $self->selected ) {
+ unless ( $self->selected eq $_[0] ) {
+ $self->send_untagged;
+ $self->selected->close;
+ }
+ $self->selected_read_only(0);
+ }
+ return $self->_selected(@_);
+}
+
+=head2 greeting
+
+Sends out a one-line untagged greeting to the client.
+
+=cut
+
sub greeting {
my $self = shift;
- $self->out( '* OK IMAP4rev1 Server' . "\r\n" );
+ $self->untagged_response('OK IMAP4rev1 Server');
}
+=head2 handle_lines
+
+The main line handling loop. Since we are using L<Coro>, this cedes
+to other coroutines whenever we block, given them a chance to run. We
+additionally cede after handling every command.
+
+=cut
+
sub handle_lines {
- my $self = shift;
- while ($self->io_handle and $_ = $self->io_handle->getline()) {
+ my $self = shift;
+ while ( $self->io_handle and $_ = $self->io_handle->getline() ) {
$self->handle_command($_);
cede;
}
- $self->log("-(@{[$self]},@{[$self->auth ? $self->auth->user : '???']},@{[$self->is_selected ? $self->selected->full_path : 'unselected']}): Connection closed by remote host");
+ $self->log(
+ "-(@{[$self]},@{[$self->auth ? $self->auth->user : '???']},@{[$self->is_selected ? $self->selected->full_path : 'unselected']}): Connection closed by remote host"
+ );
$self->close;
}
+=head2 handle_command
+
+Handles a single line from the client. This is not quite the same as
+handling a command, because of client literals and continuation
+commands.
+
+=cut
+
sub handle_command {
- my $self = shift;
+ my $self = shift;
my $content = shift;
local $self->server->{connection} = $self;
- local $self->server->{model} = $self->model;
- local $self->server->{auth} = $self->auth;
+ local $self->server->{model} = $self->model;
+ local $self->server->{auth} = $self->auth;
- $self->log("C(@{[$self]},@{[$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);
@@ -66,35 +172,55 @@
);
return if $handler->has_literal;
- eval {
- $handler->run() if $handler->validate;
- };
- if (my $error = $@) {
+ eval { $handler->run() if $handler->validate; };
+ if ( my $error = $@ ) {
$handler->no_command("Server error");
$self->log($error);
}
}
+=head2 pending
+
+If a connection has pending state, contains the callback that will
+recieve the next line of input.
+
+=cut
+
+=head2 close
+
+Shuts down this connection, also closing the model and mailboxes.
+
+=cut
+
sub close {
my $self = shift;
- $self->server->connections([grep {$_ ne $self} @{$self->server->connections}]);
- if ($self->io_handle) {
+ $self->server->connections(
+ [ grep { $_ ne $self } @{ $self->server->connections } ] );
+ if ( $self->io_handle ) {
$self->log("Closing connection $self");
$self->io_handle->close;
$self->io_handle(undef);
}
- $self->model->close if $self->model;
+ $self->selected->close if $self->selected;
+ $self->model->close if $self->model;
}
+=head2 parse_command LINE
+
+Parses the line into the C<tag>, C<ommand>, and C<options>. Returns
+undef if parsing fails for some reason.
+
+=cut
+
sub parse_command {
my $self = shift;
my $line = shift;
$line =~ s/[\r\n]+$//;
unless ( $line =~ /^([^\(\)\{ \*\%"\\\+}]+)\s+(\w+)(?:\s+(.+?))?$/ ) {
- if ( $line !~ /^([^\(\)\{ \*\%"\\\+]+)\s+/ ) {
- $self->out("* BAD Invalid tag\r\n");
+ if ( $line !~ /^([^\(\)\{ \*\%"\\\+}]+)\s+/ ) {
+ $self->out("* BAD Invalid tag");
} else {
- $self->out("* BAD Null command ('$line')\r\n");
+ $self->out("* BAD Null command ('$line')");
}
return undef;
}
@@ -106,115 +232,148 @@
return ( $id, $cmd, $args );
}
+=head2 is_unauth
+
+Returns true if the connection is unauthenticated.
+
+=cut
+
sub is_unauth {
my $self = shift;
return not defined $self->auth;
}
+=head2 is_auth
+
+Returns true if the connection is authenticated.
+
+=cut
+
sub is_auth {
my $self = shift;
return defined $self->auth;
}
+=head2 is_selected
+
+Returns true if the connection has selected a mailbox.
+
+=cut
+
sub is_selected {
my $self = shift;
return defined $self->selected;
}
+=head2 is_encrypted
+
+Returns true if the connection is protected by SSL or TLS.
+
+=cut
+
sub is_encrypted {
- my $self = shift;
+ my $self = shift;
my $handle = $self->io_handle;
- $handle = tied(${$handle})->[0];
+ $handle = tied( ${$handle} )->[0];
return $handle->isa("IO::Socket::SSL");
}
-sub auth {
- my $self = shift;
- if (@_) {
- $self->{auth} = shift;
- $self->server->{auth} = $self->{auth};
- $self->server->model_class->require || warn $@;
- $self->model(
- $self->server->model_class->new( { auth => $self->{auth} } ) );
- }
- return $self->{auth};
-}
+=head2 poll
-sub selected {
- my $self = shift;
- if (@_ and $self->selected) {
- unless ($self->selected eq $_[0]) {
- $self->send_untagged;
- $self->selected->close;
- }
- $self->selected_read_only(0);
- }
- return $self->_selected(@_);
-}
+Polls the currently selected mailbox, and resets the poll timer.
-sub untagged_response {
- my $self = shift;
- while ( my $message = shift ) {
- next unless $message;
- $self->out( "* " . $message . "\r\n" );
- }
-}
+=cut
sub poll {
my $self = shift;
- my($mbox) = @_;
- $mbox ||= $self->selected;
-
$self->selected->poll;
$self->last_poll(time);
}
+=head2 force_poll
+
+Forces a poll of the selected mailbox the next chance we get.
+
+=cut
+
sub force_poll {
my $self = shift;
$self->last_poll(0);
}
+=head2 last_poll
+
+Gets or sets the last time the selected mailbox was polled, in seconds
+since the epoch.
+
+=cut
+
+=head2 send_untagged
+
+Sends any untagged updates about the current mailbox to the client.
+
+=cut
+
sub send_untagged {
my $self = shift;
- my %args = ( expunged => 1,
- @_ );
+ my %args = (
+ expunged => 1,
+ @_
+ );
return unless $self->is_auth and $self->is_selected;
- if (time > $self->last_poll + $self->server->poll_every) {
+ if ( time >= $self->last_poll + $self->server->poll_every ) {
+
# When we poll, the things that we find should affect this
# connection as well; hence, the local to be "connection-less"
local $Net::IMAP::Server::Server->{connection};
$self->poll;
}
- for my $s (keys %{$self->untagged_fetch}) {
- my($m) = $self->get_messages($s);
- $self->untagged_response( $s
+ for my $s ( keys %{ $self->untagged_fetch } ) {
+ my ($m) = $self->get_messages($s);
+ $self->untagged_response(
+ $s
. " FETCH "
- . Net::IMAP::Server::Command->data_out( [ $m->fetch([keys %{$self->untagged_fetch->{$s}}]) ] ) );
+ . Net::IMAP::Server::Command->data_out(
+ [ $m->fetch( [ keys %{ $self->untagged_fetch->{$s} } ] ) ]
+ )
+ );
}
- $self->untagged_fetch({});
+ $self->untagged_fetch( {} );
- if ($args{expunged}) {
- # Make sure that they know of at least the existance of what's being expunged.
+ if ( $args{expunged} ) {
+
+# Make sure that they know of at least the existance of what's being expunged.
my $max = 0;
- $max = $max < $_ ? $_ : $max for @{$self->untagged_expunge};
- $self->untagged_response( "$max EXISTS" ) if $max > $self->previous_exists;
+ $max = $max < $_ ? $_ : $max for @{ $self->untagged_expunge };
+ $self->untagged_response("$max EXISTS")
+ if $max > $self->previous_exists;
# Send the expnges, clear out the temporary message store
- $self->previous_exists( $self->previous_exists - @{$self->untagged_expunge} );
- $self->untagged_response( map {"$_ EXPUNGE"} @{$self->untagged_expunge} );
- $self->untagged_expunge([]);
+ $self->previous_exists(
+ $self->previous_exists - @{ $self->untagged_expunge } );
+ $self->untagged_response( map {"$_ EXPUNGE"}
+ @{ $self->untagged_expunge } );
+ $self->untagged_expunge( [] );
$self->temporary_messages(undef);
}
# Let them know of more EXISTS
my $expected = $self->previous_exists;
- my $now = @{$self->temporary_messages || $self->selected->messages};
+ my $now = @{ $self->temporary_messages || $self->selected->messages };
$self->untagged_response( $now . ' EXISTS' ) if $expected != $now;
$self->previous_exists($now);
}
+=head2 get_messages STR
+
+Parses and returns messages fitting the given sequence range. This is
+on the connection and not the mailbox because messages have
+connection-dependent sequence numbers.
+
+=cut
+
sub get_messages {
my $self = shift;
my $str = shift;
@@ -225,39 +384,66 @@
for ( split ',', $str ) {
if (/^(\d+):(\d+)$/) {
$ids{$_}++ for $2 > $1 ? $1 .. $2 : $2 .. $1;
- } elsif (/^(\d+):\*$/ or /^\*:(\d+)$/) {
- $ids{$_}++ for @{ $messages } + 0, $1 .. @{ $messages } + 0;
+ } elsif ( /^(\d+):\*$/ or /^\*:(\d+)$/ ) {
+ $ids{$_}++ for @{$messages} + 0, $1 .. @{$messages} + 0;
} elsif (/^(\d+)$/) {
$ids{$1}++;
} elsif (/^\*$/) {
- $ids{@{$messages} + 0}++;
+ $ids{ @{$messages} + 0 }++;
}
}
return
- grep {defined} map { $messages->[ $_ - 1 ] } sort {$a <=> $b} keys %ids;
+ grep {defined}
+ map { $messages->[ $_ - 1 ] } sort { $a <=> $b } keys %ids;
}
+=head2 sequence MESSAGE
+
+Returns the sequence number for the given message.
+
+=cut
+
sub sequence {
- my $self = shift;
+ my $self = shift;
my $message = shift;
return $message->sequence unless $self->temporary_messages;
return $self->temporary_sequence_map->{$message};
}
+=head2 capability
+
+Returns the current capability list for this connection, as a string.
+Connections not under TLS or SSL always have the C<LOGINDISABLED>
+capability, and no authentication capabilities. The
+L<Net::IMAP::Server/auth_class>'s
+L<Net::IMAP::Server::DefaultAuth/sasl_provides> method is used to list
+known C<AUTH=> types.
+
+=cut
+
sub capability {
my $self = shift;
my $base = $self->server->capability;
if ( $self->is_encrypted ) {
- $base = join(" ", grep {$_ ne "STARTTLS"} split(' ', $base));
+ my $auth = $self->auth || $self->server->auth_class->new;
+ $base = join( " ",
+ grep { $_ ne "STARTTLS" } split( ' ', $base ),
+ map {"AUTH=$_"} $auth->sasl_provides );
} else {
- $base = join(" ", grep {not /^AUTH=\S+$/} split(' ', $base), "LOGINDISABLED");
+ $base = "$base LOGINDISABLED";
}
return $base;
}
+=head2 log MESSAGE
+
+Logs the message to standard error, using C<warn>.
+
+=cut
+
sub log {
my $self = shift;
my $msg = shift;
@@ -265,24 +451,44 @@
warn $msg . "\n";
}
-sub connected {
+=head2 untagged_response STRING
+
+Sends an untagged response to the client; a newline ia automatically
+appended.
+
+=cut
+
+sub untagged_response {
my $self = shift;
- return $self->io_handle and $self->io_handle->peerport;
+ $self->out("* $_") for grep defined, @_;
}
+=head2 out STRING
+
+Sends the mesage to the client. If the client's connection has
+dropped, or the send fails for whatever reason, L</close> the
+connection and then abort the coroutine; in which case, this function
+never returns!
+
+=cut
+
sub out {
my $self = shift;
my $msg = shift;
- if ($self->io_handle and $self->io_handle->peerport) {
- if ($self->io_handle->print($msg)) {
- $self->log("S(@{[$self]},@{[$self->auth ? $self->auth->user : '???']},@{[$self->is_selected ? $self->selected->full_path : 'unselected']}): $msg");
+ if ( $self->io_handle and $self->io_handle->peerport ) {
+ if ( $self->io_handle->print( $msg . "\r\n" ) ) {
+ $self->log(
+ "S(@{[$self]},@{[$self->auth ? $self->auth->user : '???']},@{[$self->is_selected ? $self->selected->full_path : 'unselected']}): $msg"
+ );
} else {
$self->close;
+
# Bail out; never returns
$Coro::current->cancel;
}
} else {
$self->close;
+
# Bail out; never returns
$Coro::current->cancel;
}
Modified: Net-IMAP-Server/lib/Net/IMAP/Server/DefaultAuth.pm
==============================================================================
--- Net-IMAP-Server/lib/Net/IMAP/Server/DefaultAuth.pm (original)
+++ Net-IMAP-Server/lib/Net/IMAP/Server/DefaultAuth.pm Wed Jan 30 17:16:59 2008
@@ -6,8 +6,52 @@
use base 'Class::Accessor';
__PACKAGE__->mk_accessors(qw(user));
+=head1 NAME
+
+Net::IMAP::Server::DefaultAuth - Encapsulates per-connection
+authorization information for an IMAP user.
+
+=head1 DESCRIPTION
+
+IMAP credentials are passed in one of two ways: using the L<LOGIN>
+command, or the C<AUTHENTICATE> command. L<LOGIN> sends the password
+unencrpyted; note, however, that L<Net::IMAP::Server> will not allow
+the LOGIN command unless the connection is protected by eiher SSL or
+TLS. Thus, even when the C<LOGIN> command is used, the password is
+not sent in the clear.
+
+The default implementation accepts any username and password. Most
+subclasses will simply want to override L</auth_plain>, unless they
+need to implement other forms of authorization than C<LOGIN> or
+C<AUTHENTICATE PLAIN>.
+
+=cut
+
+=head1 METHODS
+
+=head2 user [VALUE]
+
+Gets or sets the plaintext username of the authenticated user.
+
+=head2 provides_plain
+
+If L</provides_plain> returns true (the default), C<LOGIN> capability
+will be advertised when under a layer, and L</auth_plain> will be
+called if the user sends the C<LOGIN> command.
+
+=cut
+
sub provides_plain { return 1; }
+=head2 auth_plain USER, PASSWORD
+
+Returns true if the given C<USER> is allowed to log in using the
+provided C<PASSWORD>. This should also set L</user> to the username
+if login was successful. This path is used by both C<LOGIN> and
+C<AUTHENTICATE PLAIN> commands.
+
+=cut
+
sub auth_plain {
my $self = shift;
my ( $user, $pass ) = @_;
@@ -15,13 +59,28 @@
return 1;
}
-sub provides_sasl {
+=head2 sasl_provides
+
+The C<AUTHENTICATE> command checks that the provided SASL
+authentication type is in the list that L</sasl_provides> returns. It
+defaults to only C<PLAIN>.
+
+=cut
+
+sub sasl_provides {
my $self = shift;
- my $type = shift;
- return $type eq "PLAIN" ? 1 : 0;
+ return ("PLAIN");
}
-sub plain {
+=head2 sasl_plain
+
+Called when the client requests C<PLAIN> SASL authentication. This
+parses the SASL protocal, and defers to L</auth_plain> to determine if
+the username and password is actually allowed to log in.
+
+=cut
+
+sub sasl_plain {
my $self = shift;
return sub {
my $line = shift;
@@ -32,6 +91,33 @@
};
}
-sub client_id {}
+=head client_id
+
+Called when the client provides identifying information via the C<ID>
+command; by default, does nothing. See RFC 2971.
+
+=cut
+
+sub client_id { }
+
+=head1 IMPLEMENTING NEW SASL METHODS
+
+The L</sasl_plain> method is a simple example of implementing a SASL
+protocol, albeat a very simple one. SASL authentication methods
+should expect to be called with no arguments, and should return an
+anonymous function, which will be called each time the client
+transmits more information.
+
+Each time it is called, it will be passed the client data, which will
+already have been base-64 decoded (the exception being the first time
+it is called, when it will be called with the empty string).
+
+If the fnuction returns a scalar reference, the scalar will be base-64
+encoded and transmitted to the client. Anthing which is not a scalar
+reference will be interpreted as a boolean, as to whether the
+authentication was successful. Successful authentications should be
+sure to set L</user> themselves.
+
+=cut
1;
Modified: Net-IMAP-Server/lib/Net/IMAP/Server/DefaultModel.pm
==============================================================================
--- Net-IMAP-Server/lib/Net/IMAP/Server/DefaultModel.pm (original)
+++ Net-IMAP-Server/lib/Net/IMAP/Server/DefaultModel.pm Wed Jan 30 17:16:59 2008
@@ -8,6 +8,27 @@
my %roots;
+=head1 NAME
+
+Net::IMAP::Server::DefaultModel - Encapsulates per-connection
+information about the layout of IMAP folders.
+
+=head1 DESCRIPTION
+
+This class represents an abstract model backend to the IMAP server; it
+it meant to be overridden by server implementations. Primarily,
+subclasses are expected to override L</init> to set up their folder
+structure.
+
+=head1 METHODS
+
+=head2 new
+
+This class is created when the client has successfully authenticated
+to the server.
+
+=cut
+
sub new {
my $class = shift;
my $self = $class->SUPER::new(@_);
@@ -15,6 +36,17 @@
return $self;
}
+=head2 init
+
+Called when the class is instantiated, with no arguments. Subclasses
+should override this methtod to inspect the L</auth> object, and
+determine what folders the user should have. The primary purpose of
+this method is to set L</root> to the top level of the mailbox tree.
+The root is expected to contain a mailbox named C<INBOX>, which should
+have L<Net::IMAP::Server::Mailbox/is_inbox> set.
+
+=cut
+
sub init {
my $self = shift;
my $user = $self->auth->user || 'default';
@@ -22,42 +54,61 @@
if ( $roots{$user} ) {
$self->root( $roots{$user} );
} else {
- $self->root( $self->mailbox() )
- ->add_child( name => "INBOX", is_inbox => 1 )
- ->add_child( name => $user );
+ $self->root( Net::IMAP::Server::Mailbox->new() )
+ ->add_child( name => "INBOX", is_inbox => 1 )
+ ->add_child( name => $user );
$roots{$user} = $self->root;
}
return $self;
}
+=head2 close
+
+Called when this model's connection closes, for any reason. By
+default, does nothing.
+
+=cut
+
sub close {
}
+=head2 split PATH
+
+Utility method which splits a given C<PATH> according to the mailbox
+seperator, as determinded by the
+L<Net::IMAP::Server::Mailbox/seperator> of the L</root>.
+
+=cut
+
sub split {
my $self = shift;
return grep {length} split quotemeta $self->root->seperator, shift;
}
+=head2 lookup PATH
+
+Given a C<PATH>, returns the L<Net::IMAP::Server::Mailbox> for that
+path, or undef if none matches.
+
+=cut
+
sub lookup {
my $self = shift;
my $name = shift;
my @parts = $self->split($name);
- my $part = $self->root;
+ my $part = $self->root;
return undef unless @parts;
while (@parts) {
return undef unless @{ $part->children };
my $find = shift @parts;
- my @match = grep { $_->is_inbox ? uc $find eq "INBOX" : $_->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];
}
return $part;
}
-sub mailbox {
- my $self = shift;
- return Net::IMAP::Server::Mailbox->new( { model => $self, @_ } );
-}
-
1;
Modified: Net-IMAP-Server/lib/Net/IMAP/Server/Mailbox.pm
==============================================================================
--- Net-IMAP-Server/lib/Net/IMAP/Server/Mailbox.pm (original)
+++ Net-IMAP-Server/lib/Net/IMAP/Server/Mailbox.pm Wed Jan 30 17:16:59 2008
@@ -10,27 +10,92 @@
qw(name is_inbox parent children _path uidnext uids uidvalidity messages subscribed is_selectable)
);
+=head1 NAME
+
+Net::IMAP::Server::Mailbox - A user's view of a mailbox
+
+=head1 DESCRIPTION
+
+This class encapsulates the view of messages in a mailbox. You may
+wish to subclass this class in order to source our messages from, say,
+a database.
+
+=head1 METHODS
+
+=head2 Initialization
+
+=head3 new
+
+Creates a new mailbox; returns C<undef> if a mailbox with the same
+full path already exists. It calls L</init>, then L</load_data>.
+
+=cut
+
sub new {
my $class = shift;
my $self = $class->SUPER::new(@_);
- return if $self->parent and grep {$self->full_path eq $_->full_path} @{$self->parent->children};
+ return
+ if $self->parent
+ and grep { $self->full_path eq $_->full_path }
+ @{ $self->parent->children };
$self->init;
$self->load_data;
return $self;
}
+=head3 init
+
+Sets up basic properties of the mailbox:
+
+=over
+
+=item *
+
+L</uidnext> is set to 1000
+
+=item *
+
+L</messages> and L</uids> are initialized to an empty list reference
+and an empty hash reference, respectively.
+
+=item *
+
+L</children> is set to an empty list reference.
+
+=item *
+
+L</uidvalidity> is set to the number of seconds since the epoch.
+
+=item *
+
+L</subscribed> and L</is_selectable> are set true.
+
+=back
+
+=cut
+
sub init {
my $self = shift;
-
$self->uidnext(1000);
$self->messages( [] );
$self->uids( {} );
$self->children( [] );
- $self->uidvalidity( scalar time );
- $self->subscribed( 1 );
- $self->is_selectable( 1 );
+ $self->uidvalidity(time);
+ $self->subscribed(1);
+ $self->is_selectable(1);
}
+=head3 load_data
+
+This default mailbox implementation attempts to find a C<mbox> file
+whose name is based on the full path of the mailbox, and load messages
+from that file. It makes no attempt to write back any changes to the
+file.
+
+Subclasses will probably wish to override this method.
+
+=cut
+
sub load_data {
my $self = shift;
my $name = $self->full_path;
@@ -47,15 +112,27 @@
}
}
-sub seperator {
- return "/";
-}
+=head2 Actions
-sub selected {
- my $self = shift;
- return $Net::IMAP::Server::Server->connection->selected
- and $Net::IMAP::Server::Server->connection->selected eq $self;
-}
+=head3 poll
+
+Called when the server wishes the mailbox to update its state. By
+default, does nothing. Subclasses will probably wish to override this
+method.
+
+=cut
+
+sub poll { }
+
+=head3 add_message MESSAGE
+
+Adds the gven L<Net::IMAP::Server::Message> C<MESSAGE> to the mailbox,
+setting its L<Net::IMAP::Server::Message/sequence> and
+L<Net::IMAP::Server::Message/mailbox>.
+L<Net::IMAP::Server::Message/uid> is set to L</uidnext> if the message
+does not already have a C<uid>.
+
+=cut
sub add_message {
my $self = shift;
@@ -67,8 +144,9 @@
push @{ $self->messages }, $message;
# Some messages may supply their own uids
- if ($message->uid) {
- $self->uidnext( $message->uid + 1 ) if $message->uid >= $self->uidnext;
+ if ( $message->uid ) {
+ $self->uidnext( $message->uid + 1 )
+ if $message->uid >= $self->uidnext;
} else {
$message->uid( $self->uidnext );
$self->uidnext( $self->uidnext + 1 );
@@ -77,187 +155,366 @@
# Also need to add it to anyone that has this folder as a
# temporary message store
- for my $c (Net::IMAP::Server->concurrent_mailbox_connections($self)) {
+ for my $c ( Net::IMAP::Server->concurrent_mailbox_connections($self) ) {
next unless $c->temporary_messages;
- push @{$c->temporary_messages}, $message;
- $c->temporary_sequence_map->{$message} = scalar @{$c->temporary_messages};
+ push @{ $c->temporary_messages }, $message;
+ $c->temporary_sequence_map->{$message}
+ = scalar @{ $c->temporary_messages };
}
return $message;
}
-sub get_uids {
- my $self = shift;
- my $str = shift;
+=head3 add_child [...]
- my %ids;
- for ( split ',', $str ) {
- if (/^(\d+):(\d+)$/) {
- $ids{$_}++ for $2 > $1 ? $1 .. $2 : $2 .. $1;
- } elsif (/^(\d+):\*$/ or /^\*:(\d+)$/) {
- $ids{$_}++ for $self->messages->[-1]->uid, $1 .. $self->messages->[-1]->uid;
- } elsif (/^(\d+)$/) {
- $ids{$1}++;
- } elsif (/^\*$/) {
- $ids{ $self->messages->[-1]->uid }++;
- }
- }
- return
- grep {defined} map { $self->uids->{$_} } sort {$a <=> $b} keys %ids;
-}
+Creates a mailbox under this mailbox, of the same class as this
+mailbox is. Any arguments are passed to L</new>. Returns the newly
+added subfolder, or undef if a folder with that name already exists.
+
+=cut
sub add_child {
my $self = shift;
- my $node = ( ref $self )
- ->new( { @_, parent => $self } );
+ my $node = ( ref $self )->new( { @_, parent => $self } );
return unless $node;
push @{ $self->children }, $node;
return $node;
}
+=head3 create [...]
+
+Identical to L</add_child>. Should return false if the create is
+denied or fails.
+
+=cut
+
sub create {
my $self = shift;
return $self->add_child(@_);
}
+=head3 reparent MAILBOX
+
+Reparents this mailbox to be a child of the given
+L<Net::IMAP::Server::Mailbox> C<MAILBOX>. Shold return 0 if the
+reparenting is denied or fails.
+
+=cut
+
sub reparent {
- my $self = shift;
+ my $self = shift;
my $parent = shift;
- $self->parent->children([grep {$_ ne $self} @{$self->parent->children}]);
- push @{$parent->children}, $self;
+ $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};
+ push @uncache, @{ $o->children };
}
return 1;
}
+=head3 delete
+
+Deletes this mailbox, removing it from its parent's list of children.
+Should return false if the deletion is denied or fails.
+
+=cut
+
sub delete {
my $self = shift;
- $self->parent->children([grep {$_ ne $self} @{$self->parent->children}]);
+ $self->parent->children(
+ [ grep { $_ ne $self } @{ $self->parent->children } ] );
return 1;
}
+=head3 expunge [ARRAYREF]
+
+Expunges messages marked as C<\Deleted>. If an arrayref of message
+sequence numbers is provided, only expunges message from that set.
+
+=cut
+
+sub expunge {
+ my $self = shift;
+ my $only = shift;
+ return if $only and not @{$only};
+ my %only;
+ $only{$_}++ for @{ $only || [] };
+
+ my @ids;
+ my $offset = 0;
+ my @messages = @{ $self->messages };
+ $self->messages(
+ [ grep {
+ not( $_->has_flag('\Deleted')
+ and ( not $only or $only{ $_->sequence } ) )
+ } @messages
+ ]
+ );
+ for my $c ( Net::IMAP::Server->concurrent_mailbox_connections($self) ) {
+
+ # Ensure that all other connections with this selected get a
+ # temporary message list, if they don't already have one
+ unless (
+ ( $Net::IMAP::Server::Server->connection
+ and $c eq $Net::IMAP::Server::Server->connection
+ )
+ or $c->temporary_messages
+ )
+ {
+ $c->temporary_messages( [@messages] );
+ $c->temporary_sequence_map( {} );
+ $c->temporary_sequence_map->{$_} = $_->sequence for @messages;
+ }
+ }
+
+ for my $m (@messages) {
+ if ( $m->has_flag('\Deleted')
+ and ( not $only or $only{ $m->sequence } ) )
+ {
+ push @ids, $m->sequence - $offset;
+ delete $self->uids->{ $m->uid };
+ $offset++;
+ $m->expunge;
+ } elsif ($offset) {
+ $m->sequence( $m->sequence - $offset );
+ }
+ }
+
+ for my $c ( Net::IMAP::Server->concurrent_mailbox_connections($self) ) {
+
+ # Also, each connection gets these added to their expunge list
+ push @{ $c->untagged_expunge }, @ids;
+ }
+
+ return 1;
+}
+
+=head3 append MESSAGE
+
+Appends, and returns, the given C<MESSAGE>, which should be a string
+containing the message. Returns false is the append is denied or
+fails.
+
+=cut
+
+sub append {
+ my $self = shift;
+ my $m = Net::IMAP::Server::Message->new(@_);
+ $m->set_flag( '\Recent', 1 );
+ $self->add_message($m);
+ return $m;
+}
+
+=head3 close
+
+Called when the client selects a different mailbox, or when the
+client's connection closes. By default, does nothing.
+
+=cut
+
+sub close { }
+
+=head2 Inspection
+
+=head3 seperator
+
+Returns the path seperator. Note that only the path seperator of the
+root mailbox matters. Defaults to a forward slash.
+
+=cut
+
+sub seperator {
+ return "/";
+}
+
+=head3 full_path
+
+Returns the full path to this mailbox.
+
+=cut
+
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 );
+ !$self->parent ? ""
+ : !$self->parent->parent ? $self->name
+ : $self->parent->full_path . $self->seperator . $self->name
+ );
return $self->_path;
}
+=head3 flags
+
+Returns the list of flags that this mailbox supports.
+
+=cut
+
sub flags {
my $self = shift;
return qw(\Answered \Flagged \Deleted \Seen \Draft);
}
+=head3 can_set_flag FLAG
+
+Returns true if the client is allowed to set the given flag in this
+mailbox; this simply scans L</flags> to check.
+
+=cut
+
sub can_set_flag {
my $self = shift;
my $flag = shift;
- return 1 if grep {lc $_ eq lc $flag} $self->flags;
+ return 1 if grep { lc $_ eq lc $flag } $self->flags;
return;
}
+=head3 exists
+
+Returns the number of messages in this mailbox. Observing this also
+sets the "high water mark" for notifying the client of messages added.
+
+=cut
+
sub exists {
my $self = shift;
- $Net::IMAP::Server::Server->connection->previous_exists( scalar @{ $self->messages } )
- if $self->selected;
+ $Net::IMAP::Server::Server->connection->previous_exists(
+ scalar @{ $self->messages } )
+ if $self->selected;
return scalar @{ $self->messages };
}
+=head3 recent
+
+Returns the number of messages which have the C<\Recent> flag set.
+
+=cut
+
sub recent {
my $self = shift;
- return scalar grep {$_->has_flag('\Recent')} @{$self->messages};
+ return scalar grep { $_->has_flag('\Recent') } @{ $self->messages };
}
+=head3 unseen
+
+Returns the number of messages which do not have the C<\Seen> flag set.
+
+=cut
+
sub unseen {
my $self = shift;
- return scalar grep {not $_->has_flag('\Seen')} @{$self->messages};
+ return scalar grep { not $_->has_flag('\Seen') } @{ $self->messages };
}
+=head3 permanentflags
+
+Returns the flags which will be stored permanently for this mailbox;
+defaults to the same set as L</flags> returns.
+
+=cut
+
sub permanentflags {
my $self = shift;
return $self->flags;
}
+=head3 read_only
+
+Returns true if this mailbox is read-only. By default, always returns
+false.
+
+=cut
+
sub read_only {
my $self = shift;
return 0;
}
-sub expunge {
+=head3 selected
+
+Returns true if this mailbox is the mailbox selected by the current
+L<Net::IMAP::Server::Connection>.
+
+=cut
+
+sub selected {
my $self = shift;
- my $only = shift;
- return if $only and not @{$only};
- my %only; $only{$_}++ for @{$only || []};
+ return $Net::IMAP::Server::Server->connection->selected
+ and $Net::IMAP::Server::Server->connection->selected eq $self;
+}
- my @ids;
- my $offset = 0;
- my @messages = @{ $self->messages };
- $self->messages( [ grep { not ( $_->has_flag('\Deleted') and (not $only or $only{$_->sequence}))} @messages ] );
- for my $c (Net::IMAP::Server->concurrent_mailbox_connections($self)) {
- # Ensure that all other connections with this selected get a
- # temporary message list, if they don't already have one
- unless (($Net::IMAP::Server::Server->connection and $c eq $Net::IMAP::Server::Server->connection)
- or $c->temporary_messages) {
- $c->temporary_messages([@messages]);
- $c->temporary_sequence_map({});
- $c->temporary_sequence_map->{$_} = $_->sequence for @messages;
- }
- }
+=head3 get_uids STR
- for my $m (@messages) {
- if ( $m->has_flag('\Deleted') and (not $only or $only{$m->sequence})) {
- push @ids, $m->sequence - $offset;
- delete $self->uids->{$m->uid};
- $offset++;
- $m->expunge;
- } elsif ($offset) {
- $m->sequence( $m->sequence - $offset );
- }
- }
+Parses and returns messages fitting the given UID range.
- for my $c (Net::IMAP::Server->concurrent_mailbox_connections($self)) {
- # Also, each connection gets these added to their expunge list
- push @{$c->untagged_expunge}, @ids;
+=cut
+
+sub get_uids {
+ my $self = shift;
+ my $str = shift;
+
+ my %ids;
+ for ( split ',', $str ) {
+ if (/^(\d+):(\d+)$/) {
+ $ids{$_}++ for $2 > $1 ? $1 .. $2 : $2 .. $1;
+ } elsif ( /^(\d+):\*$/ or /^\*:(\d+)$/ ) {
+ $ids{$_}++
+ for $self->messages->[-1]->uid,
+ $1 .. $self->messages->[-1]->uid;
+ } elsif (/^(\d+)$/) {
+ $ids{$1}++;
+ } elsif (/^\*$/) {
+ $ids{ $self->messages->[-1]->uid }++;
+ }
}
+ return
+ grep {defined} map { $self->uids->{$_} } sort { $a <=> $b } keys %ids;
}
-sub append {
+=head3 get_messages STR
+
+Parses and returns messages fitting the given sequence range. Note
+that since sequence numbers are connection-dependent, this simply
+passes the buck to L</Net::IMAP::Server::Connection/get_messages>.
+
+=cut
+
+sub get_messages {
my $self = shift;
- my $m = Net::IMAP::Server::Message->new(@_);
- $m->set_flag('\Recent', 1);
- $self->add_message($m);
- return $m;
+ return $Net::IMAP::Server::Server->connection->get_messages(@_);
}
-sub poll {}
+=head3 prep_for_destroy
+
+Called before the mailbox is destroyed; this deals with cleaning up
+the several circular references involved. In turn, it calls
+L</prep_for_destroy> on all child mailboxes, as well as all messages
+it has.
+
+=cut
sub prep_for_destroy {
my $self = shift;
- my @kids = @{$self->children || []};
- $self->children([]);
+ my @kids = @{ $self->children || [] };
+ $self->children( [] );
$_->prep_for_destroy for @kids;
- my @messages = @{$self->messages || []};
- $self->messages([]);
- $self->uids({});
+ my @messages = @{ $self->messages || [] };
+ $self->messages( [] );
+ $self->uids( {} );
$_->prep_for_destroy for @messages;
$self->parent(undef);
}
-sub close {}
-
package Email::IMAPFolder;
use base 'Email::Folder';
-use YAML;
sub bless_message {
my $self = shift;
Modified: Net-IMAP-Server/lib/Net/IMAP/Server/Message.pm
==============================================================================
--- Net-IMAP-Server/lib/Net/IMAP/Server/Message.pm (original)
+++ Net-IMAP-Server/lib/Net/IMAP/Server/Message.pm Wed Jan 30 17:16:59 2008
@@ -12,11 +12,24 @@
# Canonical capitalization
my %FLAGS;
-$FLAGS{lc $_} = $_ for qw(\Answered \Flagged \Deleted \Seen \Draft);
+$FLAGS{ lc $_ } = $_ for qw(\Answered \Flagged \Deleted \Seen \Draft);
use base 'Class::Accessor';
-__PACKAGE__->mk_accessors(qw(sequence mailbox uid _flags mime internaldate expunged));
+__PACKAGE__->mk_accessors(
+ qw(sequence mailbox uid _flags mime internaldate expunged));
+
+=head1 NAME
+
+Net::IMAP::Server::Message - Represents a message stored in a user's mailbox
+
+=head1 METHODS
+
+=head2 new STR
+
+Creates a new message, from an RFC2822 string.
+
+=cut
sub new {
my $class = shift;
@@ -27,89 +40,230 @@
return $self;
}
+=head2 mailbox [MAILBOX]
+
+Gets or sets the L<Net::IMAP::Server::Mailbox> that this message is
+in.
+
+=head2 sequence [INTEGER]
+
+Gets or sets the sequence number of this message in its mailbox.
+Note, however, that due to the semi-transactional nature of IMAP,
+different connections may see a message as having different sequence
+numbers! The sequence number stored on the message is the sequence
+number that a new connection would see; to find out what a connection
+believes the sequence number of a message to be, use
+L<Net::IMAP::Server::Connection/sequence>.
+
+=head2 uid [INTEGER]
+
+Gets or sets the UID of the message. This, paired with the name and
+UIDVALIDITY of its mailbox, is a unique designator of the message.
+
+=head2 internaldate [STRING]
+
+Gets ot sets the string representing when the message was recieved by
+the server. According to RFC specification, this must be formatted as
+C<01-Jan-2008 15:42 -0500>.
+
+=head2 expunge
+
+Marks the message as expunged -- this is called by
+L<Net::IMAP::Server::Mailbox/expunge>, which deals with actually
+removing the mesage from the appropriate places..
+
+=cut
+
sub expunge {
my $self = shift;
$self->expunged(1);
}
+=head2 expunged
+
+=cut
+
+=head2 copy_allowed MAILBOX
+
+Returns true if copying this message to the given
+L<Net::IMAP::Server::Mailbox> C<MAILBOX> is allowed. By default,
+always returns true;
+
+=cut
+
sub copy_allowed {
return 1;
}
-sub mime_header {
- my $self = shift;
- return $self->mime->header_obj;
-}
+=head2 copy MAILBOX
+
+Copies the message into the given L<Net::IMAP::Server::Mailbox>
+C<MAILBOX>, and returns the new message.
+
+=cut
sub copy {
- my $self = shift;
+ 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->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);
+ $clone->set_flag( $_, 1 ) for ( '\Recent', $self->flags );
$mailbox->add_message($clone);
return $clone;
}
+=head2 set_flag FLAG [, SILENT]
+
+Sets the given flag on the message; if a true value is passed for
+C<SILENT>, mailboxes will not send notification of the change to the
+client. Returns the old value.
+
+=cut
+
sub set_flag {
my $self = shift;
- my $flag = shift;
- $flag = $FLAGS{lc $flag} || $flag;
- my $old = exists $self->_flags->{$flag};
+ my ( $flag, $silent ) = @_;
+ $flag = $FLAGS{ lc $flag } || $flag;
+ my $old = exists $self->_flags->{$flag};
$self->_flags->{$flag} = 1;
my $changed = not $old;
- if ($changed and not @_) {
- for my $c (Net::IMAP::Server->concurrent_mailbox_connections($self->mailbox)) {
- $c->untagged_fetch->{$c->sequence($self)}{FLAGS}++ unless $c->ignore_flags;
+ if ( $changed and not $silent ) {
+ for my $c (
+ Net::IMAP::Server->concurrent_mailbox_connections(
+ $self->mailbox
+ )
+ )
+ {
+ $c->untagged_fetch->{ $c->sequence($self) }{FLAGS}++
+ unless $c->ignore_flags;
}
}
-
+
return $changed;
}
+=head2 clear_flag FLAG [, SILENT]
+
+Clears the given flag on the message; if a true value is passed for
+C<SILENT>, mailboxes will not send notification of the change to the
+client. Returns the old value.
+
+=cut
+
sub clear_flag {
my $self = shift;
- my $flag = shift;
- $flag = $FLAGS{lc $flag} || $flag;
- my $old = exists $self->_flags->{$flag};
+ my ( $flag, $silent ) = @_;
+ $flag = $FLAGS{ lc $flag } || $flag;
+ my $old = exists $self->_flags->{$flag};
delete $self->_flags->{$flag};
my $changed = $old;
- if ($changed and not @_) {
- for my $c (Net::IMAP::Server->concurrent_mailbox_connections($self->mailbox)) {
- $c->untagged_fetch->{$c->sequence($self)}{FLAGS}++ unless $c->ignore_flags;
+ if ( $changed and not $silent ) {
+ for my $c (
+ Net::IMAP::Server->concurrent_mailbox_connections(
+ $self->mailbox
+ )
+ )
+ {
+ $c->untagged_fetch->{ $c->sequence($self) }{FLAGS}++
+ unless $c->ignore_flags;
}
}
return $changed;
}
+=head2 has_flag FLAG
+
+Returns true if the message has the given flag set.
+
+=cut
+
sub has_flag {
my $self = shift;
my $flag = shift;
- $flag = $FLAGS{lc $flag} || $flag;
+ $flag = $FLAGS{ lc $flag } || $flag;
return exists $self->_flags->{$flag};
}
+=head2 flags
+
+Returns the list of flags which are set on the message.
+
+=cut
+
sub flags {
my $self = shift;
return sort keys %{ $self->_flags };
}
+=head2 store STRING FLAGS
+
+Sets the given C<FLAGS>, which should be an array reference, on the
+message. C<STRING> should be C<+FLAGS>, C<-FLAGS>, or C<FLAGS>; the
+first sets the set of flags, the second unsets the set of flags, and
+the third changes the message's flags to exactly match the given set.
+
+=cut
+
+sub store {
+ my $self = shift;
+ my ( $what, $flags ) = @_;
+ my @flags = @{$flags};
+ if ( $what =~ /^-/ ) {
+ $self->clear_flag($_) for grep { $self->has_flag($_) } @flags;
+ } elsif ( $what =~ /^\+/ ) {
+ $self->set_flag($_) for grep { not $self->has_flag($_) } @flags;
+ } else {
+ $self->set_flag($_) for grep { not $self->has_flag($_) } @flags;
+ $self->clear_flag($_) for grep {
+ $a = $_;
+ not grep { lc $a eq lc $_ } @flags
+ } $self->flags;
+ }
+}
+
+=head2 mime_header
+
+Returns the L<Email::Simple::Header> of the message.
+
+=cut
+
+sub mime_header {
+ my $self = shift;
+ return $self->mime->header_obj;
+}
+
+=head2 mime [OBJ]
+
+Gets or sets the L<Email::MIME> object for this message.
+
+=cut
+
+=head2 fetch SPEC
+
+Takes C<SPEC>, which is either a string or an array refence of
+strings, and returns a list of strings or data structures which match
+the specification. The specification is defined by section 7.4.2 of
+RFC 3501.
+
+=cut
+
sub fetch {
my $self = shift;
my $spec = shift;
- $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/]
+ 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";
@@ -125,7 +279,7 @@
my @out;
for my $part (@parts) {
- push @out, \(uc $part);
+ push @out, \( uc $part );
# Now that we've split out the right tag, do some aliasing
if ( uc $part eq "RFC822" ) {
@@ -176,14 +330,16 @@
$result = $self->mime->as_string unless @sections;
for (@sections) {
if ( uc $_ eq "HEADER" or uc $_ eq "MIME" ) {
- $result = ($mime ? $mime->header_obj : $self->mime_header)->as_string . "\r\n";
+ $result = ( $mime ? $mime->header_obj : $self->mime_header )
+ ->as_string . "\r\n";
} elsif ( uc $_ eq "FIELDS" ) {
my %case;
my $mime_header = $mime ? $mime->header_obj : $self->mime_header;
$case{ uc $_ } = $_ for $mime_header->header_names;
my $copy = Email::Simple::Header->new("");
for my $h ( @{$extras} ) {
- $copy->header_set( $case{$h} || $h => $mime_header->header($h) );
+ $copy->header_set( $case{$h}
+ || $h => $mime_header->header($h) );
}
$result = $copy->as_string ? $copy->as_string . "\r\n" : "";
} elsif ( uc $_ eq "TEXT" ) {
@@ -227,10 +383,11 @@
# hate thee. Make the mime structures, hack them into the
# IMAP format, concat them, and insert their reference so they
# get spat out as-is.
- my @parts = $mime->parts;
+ my @parts = $mime->parts;
@parts = () if @parts == 1 and $parts[0] == $mime;
my $parts = join '', map {
- Net::IMAP::Server::Command->data_out( $self->mime_bodystructure( $_, $long ) )
+ Net::IMAP::Server::Command->data_out(
+ $self->mime_bodystructure( $_, $long ) )
} @parts;
return [
@@ -298,12 +455,15 @@
my $mime = $self->mime_header;
return undef unless $mime->header($header);
- return [ map { [ {type => "string", value => $_->name},
- undef,
- {type => "string", value => $_->user},
- {type => "string", value => $_->host}
- ] }
- Email::Address->parse( $mime->header($header) ) ];
+ return [
+ map {
+ [ { type => "string", value => $_->name },
+ undef,
+ { type => "string", value => $_->user },
+ { type => "string", value => $_->host }
+ ]
+ } Email::Address->parse( $mime->header($header) )
+ ];
}
sub mime_envelope {
@@ -330,22 +490,12 @@
];
}
-sub store {
- my $self = shift;
- my ( $what, $flags ) = @_;
- my @flags = @{$flags};
- if ( $what =~ /^-/ ) {
- $self->clear_flag($_) for grep { $self->has_flag($_) } @flags;
- } elsif ( $what =~ /^\+/ ) {
- $self->set_flag($_) for grep { not $self->has_flag($_) } @flags;
- } else {
- $self->set_flag($_) for grep { not $self->has_flag($_) } @flags;
- $self->clear_flag($_) for grep {
- $a = $_;
- not grep { lc $a eq lc $_ } @flags
- } $self->flags;
- }
-}
+=head2 prep_for_destroy
+
+Called by the mailbox before the message is torn down; breaks down any
+circular references.
+
+=cut
sub prep_for_destroy {
my $self = shift;
More information about the Bps-public-commit
mailing list