diff --git a/MANIFEST b/MANIFEST index 5c592d6..927c2e4 100644 --- a/MANIFEST +++ b/MANIFEST @@ -13,41 +13,6 @@ contrib/search-test.pl contrib/SimpleX.pm contrib/SimpleX.pod contrib/status.pl -inc/Net/IMAP/Server.pm -inc/Net/IMAP/Server/Command.pm -inc/Net/IMAP/Server/Command/Append.pm -inc/Net/IMAP/Server/Command/Authenticate.pm -inc/Net/IMAP/Server/Command/Capability.pm -inc/Net/IMAP/Server/Command/Check.pm -inc/Net/IMAP/Server/Command/Close.pm -inc/Net/IMAP/Server/Command/Copy.pm -inc/Net/IMAP/Server/Command/Create.pm -inc/Net/IMAP/Server/Command/Delete.pm -inc/Net/IMAP/Server/Command/Examine.pm -inc/Net/IMAP/Server/Command/Expunge.pm -inc/Net/IMAP/Server/Command/Fetch.pm -inc/Net/IMAP/Server/Command/Id.pm -inc/Net/IMAP/Server/Command/List.pm -inc/Net/IMAP/Server/Command/Login.pm -inc/Net/IMAP/Server/Command/Logout.pm -inc/Net/IMAP/Server/Command/Lsub.pm -inc/Net/IMAP/Server/Command/Namespace.pm -inc/Net/IMAP/Server/Command/Noop.pm -inc/Net/IMAP/Server/Command/Rename.pm -inc/Net/IMAP/Server/Command/Search.pm -inc/Net/IMAP/Server/Command/Select.pm -inc/Net/IMAP/Server/Command/Starttls.pm -inc/Net/IMAP/Server/Command/Status.pm -inc/Net/IMAP/Server/Command/Store.pm -inc/Net/IMAP/Server/Command/Subscribe.pm -inc/Net/IMAP/Server/Command/Uid.pm -inc/Net/IMAP/Server/Command/Unsubscribe.pm -inc/Net/IMAP/Server/Connection.pm -inc/Net/IMAP/Server/DefaultAuth.pm -inc/Net/IMAP/Server/DefaultModel.pm -inc/Net/IMAP/Server/Error.pm -inc/Net/IMAP/Server/Mailbox.pm -inc/Net/IMAP/Server/Message.pm inc/rebuild_iff_necessary.pm inc/slurp_fetchmail.pm lib/Net/IMAP/Simple/PipeSocket.pm @@ -79,13 +44,7 @@ t/55_uid_stuff.t t/60_fetch_with_grammar.t t/70_list2range.t t/75_back_and_forth.t -t/Auth.pm -t/CanFlag.pm -t/Connection.pm t/critic.t -t/Model.pm t/pod.t t/pod_coverage.t -t/Shutdown.pm -t/test_server.pm TODO diff --git a/inc/Net/IMAP/Server.pm b/inc/Net/IMAP/Server.pm deleted file mode 100644 index 9a77584..0000000 --- a/inc/Net/IMAP/Server.pm +++ /dev/null @@ -1,569 +0,0 @@ -package Net::IMAP::Server; - -use warnings; -use strict; - -use base qw/Net::Server::Coro Class::Accessor/; - -use UNIVERSAL::require; -use Coro; - -our $VERSION = '1.27'; - -=head1 NAME - -Net::IMAP::Server - A single-threaded multiplexing IMAP server -implementation, using L. - -=head1 SYNOPSIS - - use Net::IMAP::Server; - Net::IMAP::Server->new( - port => 193, - ssl_port => 993, - auth_class => "Your::Auth::Class", - model_class => "Your::Model::Class", - user => "nobody", - group => "nobody", - )->run; - -=head1 DESCRIPTION - -This model provides a complete implementation of the C -specification, along with several IMAP4rev1 extensions. It provides -separation of the mailbox and message store from the client -interaction loop. - -Note that, following RFC suggestions, login is not allowed except -under a either SSL or TLS. Thus, you are required to have a F -directory under the current working directory, containing files -F and C. Failure to do so will cause -the server to fail to start. Note that if the default paths suit your -needs, you can specify different ones using the L and -L arguments to L. - -=head1 INTERFACE - -The primary method of using this module is to supply your own model -and auth classes, which inherit from -L and -L. This allows you to back your -messages from arbitrary data sources, or provide your own -authorization backend. For the most part, the implementation of the -IMAP components should be opaque. - -=head1 METHODS - -=cut - -__PACKAGE__->mk_accessors( - qw/port ssl_port - auth_class model_class connection_class - command_class - poll_every - unauth_idle auth_idle unauth_commands - / -); - -=head2 new PARAMHASH - -Creates a new IMAP server object. This doesn't even bind to the -sockets; it merely initializes the object. It will C if it -cannot find the appropriate certificate files. Valid arguments to -C include: - -=over - -=item port - -The port to bind to. Defaults to port 1430. - -=item ssl_port - -The port to open an SSL listener on; by default, this is disabled, and -any true value enables it. - -=item auth_class - -The name of the class which implements authentication. This must be a -subclass of L. - -=item model_class - -The name of the class which implements the model backend. This must -be a subclass of L. - -=item connection_class - -On rare occasions, you may wish to subclass the connection class; this -class must be a subclass of L. - -=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. - -=item unauth_commands - -The number of commands before unauthenticated users are disconnected. -The default is 10; set to zero to disable. - -=item unauth_idle - -How long, in seconds, to wait before disconnecting idle connections -which have not authenticated yet. The default is 5 minutes; set to -zero to disable (which is not advised). - -=item auth_idle - -How long, in seconds, to wait before disconnecting authenticated -connections. By RFC specification, this B be longer than 30 -minutes. The default is an hour; set to zero to disable. - -=item server_cert - -Path to the SSL certificate that the server should use. This can be -either a relative or absolute path. - -=item server_key - -Path to the SSL certificate key that the server should use. This can -be either a relative or absolute path. - -=back - -It also accepts the following L arguments -- see its -documentation for details on their use. - -=over - -=item L - -=item L - -=item L - -=item L - -=item L - -=item L - -=item L - -=item L - -=item L - -=item L - -=item L - -=item L - -=item L - -=item L - -=item L - -=back - -=cut - -sub new { - my $class = shift; - - 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, - unauth_idle => 5*60, - auth_idle => 60*60, - unauth_commands => 10, - @_, - command_class => {}, - connection => {}, - } - ); - - $self->{server}{$_} = $self->{$_} - for grep {defined $self->{$_}} - qw/log_level log_file - syslog_logsock syslog_ident syslog_logopt syslog_facility - pid_file chroot user group - reverse_lookups allow deny cidr_allow cidr_deny - /; - - 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"; - - UNIVERSAL::require( $self->model_class ) - or die "Can't require model class: $@\n"; - $self->model_class->isa("Net::IMAP::Server::DefaultModel") - 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 objects have a way of -referring to the server -- and though L, whatever parts -of the IMAP internals they need. - -Any arguments are passed through to L. - -=cut - -sub run { - my $self = shift; - my @proto = qw/TCP/; - my @port = $self->port; - if ( $self->ssl_port ) { - push @proto, "SSL"; - push @port, $self->ssl_port; - } - local $Net::IMAP::Server::Server = $self; - $self->SUPER::run( - @_, - proto => \@proto, - port => \@port, - ); -} - -=head2 process_request - -Accepts a client connection; this method is needed for the -L infrastructure. - -=cut - -sub process_request { - my $self = shift; - my $handle = $self->{server}{client}; - my $conn = $self->connection_class->new( - io_handle => $handle, - server => $self, - ); - $self->connection($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 objects which -are currently connected to the server. - -=cut - -sub connections { - my $self = shift; - return [ values %{$self->{connection}} ]; -} - -=head2 connection - -Returns the currently active L object, -if there is one. This is determined by examining the current -coroutine. - -=cut - -sub connection { - my $class = shift; - my $self = ref $class ? $class : $Net::IMAP::Server::Server; - if (@_) { - if (defined $_[0]) { - $self->{connection}{$Coro::current . ""} = shift; - } else { - delete $self->{connection}{$Coro::current . ""}; - } - } - return $self->{connection}{$Coro::current . ""}; -} - -=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 $selected = shift || $self->connection->selected; - - return () unless $selected; - 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 is the same as the given -L (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; - - return () unless $user; - return - grep { $_->is_auth and $_->auth->user eq $user } - @{ $self->connections }; -} - -=head2 capability - -Returns the C string for the server. This string my be -modified by the connection before being sent to the client (see -L). - -=cut - -sub capability { - my $self = shift; - return "IMAP4rev1 STARTTLS CHILDREN LITERAL+ UIDPLUS ID NAMESPACE"; -} - -=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, - ); -} - -=head2 add_command NAME => PACKAGE - -Adds the given command C to the server's list of known commands. -C should be the name of a class which inherits from -L. - -=cut - -sub add_command { - my $self = shift; - my ($name, $package) = @_; - if (not $package->require) { - $self->log( 1, $@ ); - } elsif (not $package->isa('Net::IMAP::Server::Command')) { - $self->log( 1, "$package is not a Net::IMAP::Server::Command!" ); - } else { - $self->command_class->{uc $name} = $package; - } -} - -=head2 log SEVERITY, MESSAGE - -By default, defers to L, which outputs to syslog, a -logfile, or STDERR, depending how it was configured. L's -default is to print to STDERR. If you have custom logging needs, -override this method, or L. - -=cut - -1; # Magic true value required at end of module -__END__ - -=head1 Object model - -An ASCII model of the relationship between objects is below. In it, -single lines represent scalar values, and lines made of other -characters denote array references or relations. - - +----------------------------------------------+ - | | - | Server | - | | - +1-----2---------------------------------------+ - # ' ^ ^ ^ ^ - # ' | | | | - # v | | | | - # +--------1-------+ | +------1------+ | - ###>| Connection |<------2 Command | | - # +--4-----3------2+ | +-------------+ | - /-#------/ | \--------------\ | - | # v | v | - | # +----------------+ | +-------------+ | - | # | Model 2------>| Auth | | - | # +--------1-------+ | +-------------+ | - | # \---------------------------------\ - | # | | | - | # /---/ /---/ | - | # +--------------1-+ +-----------1-+ | - | ###>| Connection |<------2 Command | | - | +--4-5---3------2+ +-------------+ | - | /------/ * | \--------------\ | - | | ******** v v | - | | * +----------------+ +-------------+ | - | | * | Model 2------>| Auth | | - | | * +--------1-------+ +-------------+ | - | | * | | - | | * | /------------------------------/ - | | * | | ^ SERVER - |.|.*..........|..|................................ - | | * | | v MODEL - | | * v v - | \-*---->+-------------+<------------\ - \---*---->| Mailbox |<----------\ | - * +-1------2-3--+<----\ | | - * @ ^ $ % | | | - * @ | $$%$>+-----1---+ | | - * @ | $ %%>| Message | | | - ********@***|****%*>+---------+ | | - * @ | $ % | | - * @ | $$%$>+---------+ | | - * @ | %%>| Message 1-/ | - ********@***|******>+---------+ | - * @ | | - * @ | +---------+ | - * @ | | Message 1---/ - ********@***|******>+---------+ - @ | - @ +4----------+ - @@>| Mailbox | - +-----------+ - -The top half consists of the parts which implement the IMAP protocol -itself; the bottom contains the models for the backing store. Note -that, for the most part, the backing store is unaware of the framework -of the server itself. - -Each model has references to others, as follows: - -=over - -=item Server - -Contains references to the set of C (1). It also has a -sense of the I C (2), based on the active L -thread. - -=item Connection - -Connections hold a reference to their C (1). If the -connection has authenticated, they hold a reference to the C -object (2), and to their C (3). If a mailbox is C -(4), they hold a pointer to that, as well. Infrequently, the -connection will need to temporarily store references to the set of -C (5) which have been expunged in other -connections, but we have been unable to notify this connection of. - -=item Command - -Commands store their C (1) and C (2). - -=item Model - -Models store a reference to the C (1) of their mailbox tree, as -well as to the C (2) which gives them access to such. - -=item Mailbox - -Mailboxes store a list of C mailboxes (1), and C -(2) contained within them, which are stored in sequence order. They -also contain a hash of C (3) for fast UID retrieval of -messages. If they are not the root mailbox, they also store a -reference to their C mailbox (4). - -=item Message - -Messages store the C (1) in which they are contained. - -=back - -=head1 DEPENDENCIES - -L, L - -=head1 BUGS AND LIMITATIONS - -No bugs have been reported. - -Please report any bugs or feature requests to -C, or through the web interface at -L. - -A low-traffic mailing list exists for discussion on how to (ab)use -this module, at -L. - -=head1 AUTHOR - -Alex Vandiver C<< >> - -=head1 LICENCE AND COPYRIGHT - -Copyright (c) 2009, Best Practical Solutions, LLC. All rights reserved. - -This module is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. See L. - -=head1 DISCLAIMER OF WARRANTY - -BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY -FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN -OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES -PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER -EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE -ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH -YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL -NECESSARY SERVICING, REPAIR, OR CORRECTION. - -IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING -WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR -REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE -LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL, -OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE -THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING -RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A -FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF -SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF -SUCH DAMAGES. diff --git a/inc/Net/IMAP/Server/Command.pm b/inc/Net/IMAP/Server/Command.pm deleted file mode 100644 index 0e7606c..0000000 --- a/inc/Net/IMAP/Server/Command.pm +++ /dev/null @@ -1,399 +0,0 @@ -package Net::IMAP::Server::Command; - -use warnings; -use strict; -use bytes; - -use base 'Class::Accessor'; -use Regexp::Common qw/delimited balanced/; -__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 and L 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( [] ); - return $self; -} - -=head2 server - -Gets or sets the L associated with this command. - -=cut - -=head2 connection - -Gets or sets the L 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. If C returns a false value, it is -responsible for calling L or L 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, -L, or L to the client. - -The default implementation simply always response with -L. - -=cut - -sub run { - my $self = shift; - - $self->bad_command( "command '" . uc($self->command) . "' not recognized" ); -} - -=head2 has_literal - -Analyzes the options line, and returns true if the line has literals -(as defined in the RFC, a literal is of the form C<{42}>). If the -line has literals, installs a L -callback to continue the parsing, and returns true. - -=cut - -sub has_literal { - my $self = shift; - unless ( $self->options_str =~ /\{(\d+)(\+)?\}[\r\n]*$/ ) { - $self->parse_options; - return; - } - - my $options = $self->options_str; - 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->out("+ Continue") unless $2; - return 1; -} - -=head2 parse_options - -Parses the options, and puts the results (which may be a data -structure) into L. - -=cut - -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=>'"'}{-esc=>'\\'}|$RE{balanced}{-parens=>'()'}|\S+$RE{balanced}{-parens=>'()[]<>'}|\S+)/, - defined $str ? $str : $self->options_str - ) - { - if ( $term =~ /^$RE{delimited}{-delim=>'"'}{-esc=>'\\'}{-keep}$/ ) { - my $value = $3; - $value =~ s/\\([\\"])/$1/g; - push @parsed, $value; - } 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 ] ); -} - -=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(@_) }; -} - -=head2 options_str - -Returns the flat string representation of the options the client gave. - -=cut - -=head2 data_out DATA - -Returns a string representing the most probable IMAP string that -conveys the C. - -=over - -=item * - -Array references are converted into "parenthesized lists," and each -element is recursively output. - -=item * - -Scalar references are dereferenced and returned as-is. - -=item * - -C is output as C. - -=item * - -Scalar values containing special characters are output as literals - -=item * - -Purely numerical scalar values are output with no change - -=item * - -All other scalar values are output within quotes. - -=back - -Since the IMAP specification contains nothing which is similar to a -hash, hash references are treated specially; specifically, the C -key is taken to be how the C key should be output. Options for -C are C or C. - -=cut - -sub data_out { - my $self = shift; - my $data = shift; - if ( ref $data eq "ARRAY" ) { - return "(" . join( " ", map { $self->data_out($_) } @{$data} ) . ")"; - } elsif ( ref $data eq "SCALAR" ) { - return $$data; - } elsif ( ref $data eq "HASH" ) { - if ( $data->{type} eq "string" ) { - if ( $data =~ /[{"\r\n%*\\\[]/ ) { - return "{" . ( length( $data->{value} ) ) . "}\r\n$data"; - } else { - return '"' . $data->{value} . '"'; - } - } elsif ( $data->{type} eq "literal" ) { - return "{" . ( length( $data->{value} ) ) . "}\r\n$data"; - } - } elsif ( not ref $data ) { - if ( not defined $data ) { - return "NIL"; - } elsif ( $data =~ /[{"\r\n%*\\\[]/ ) { - return "{" . ( length($data) ) . "}\r\n$data"; - } elsif ( $data =~ /^\d+$/ ) { - return $data; - } else { - return qq{"$data"}; - } - } - 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; - $self->untagged_response( uc( $self->command ) . " $_" ) - for grep defined, @_; -} - -=head2 poll_after - -Returns a true value if the command should send untagged updates about -the 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, but only -if the command has a true L. - -=cut - -sub send_untagged { - my $self = shift; - $self->connection->send_untagged(@_) if $self->poll_after; -} - -=head2 ok_command MESSAGE [, RESPONSECODE => STRING, ...] - -Sends untagged OK responses for any C pairs, then -outputs untagged messages via L, then sends a tagged -OK with the given C. - -=cut - -sub ok_command { - my $self = shift; - my $message = shift; - my %extra_responses = (@_); - for ( keys %extra_responses ) { - $self->untagged_response( - "OK [" . uc($_) . "] " . $extra_responses{$_} ); - } - $self->send_untagged; - $self->out( $self->command_id . " OK $message" ); - return 1; -} - -=head2 ok_completed [RESPONSECODE => STRING] - -Sends an C 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 no_command MESSAGE [, RESPONSECODE => STRING, ...] - -Sends untagged NO responses for any C pairs, then -outputs untagged messages via L, then sends a tagged -OK with the given C. - -=cut - -sub no_command { - my $self = shift; - my $message = shift; - my %extra_responses = (@_); - for ( keys %extra_responses ) { - $self->untagged_response( - "NO [" . uc($_) . "] " . $extra_responses{$_} ); - } - $self->out( $self->command_id . " NO $message" ); - return 0; -} - -=head2 bad_command REASON - -Sends any untagged updates to the client using L, then -sends a tagged C response with the given C. - -=cut - -sub bad_command { - my $self = shift; - my $reason = shift; - $self->send_untagged; - $self->out( $self->command_id . " BAD $reason" ); - return 0; -} - -=head2 log SEVERITY, MESSAGE - -Defers to L. - -=cut - -sub log { - my $self = shift; - $self->connection->log(@_); -} - -=head2 out MESSAGE - -Identical to L. - -=cut - -sub out { - my $self = shift; - $self->connection->out(@_); -} - -1; diff --git a/inc/Net/IMAP/Server/Command/Append.pm b/inc/Net/IMAP/Server/Command/Append.pm deleted file mode 100644 index 19d83a9..0000000 --- a/inc/Net/IMAP/Server/Command/Append.pm +++ /dev/null @@ -1,53 +0,0 @@ -package Net::IMAP::Server::Command::Append; - -use warnings; -use strict; - -use base qw/Net::IMAP::Server::Command/; - -use DateTime::Format::Strptime; - -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 > 4; - - my $mailbox = $self->connection->model->lookup( $options[0] ); - 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 @options = $self->parsed_options; - - my $mailbox = $self->connection->model->lookup( shift @options ); - if (my $msg = $mailbox->append(pop @options)) { - if (@options and grep {ref $_} @options) { - my ($flags) = grep {ref $_} @options; - $msg->set_flag($_, 1) for @{$flags}; - } - if (@options and grep {not ref $_} @options) { - my ($time) = grep {not ref $_} @options; - my $parser = $msg->INTERNALDATE_PARSER; - my $dt = $parser->parse_datetime($time); - return $self->bad_command("Invalid date") unless $dt; - $msg->internaldate( $dt ); - } - - $self->connection->previous_exists( $self->connection->previous_exists + 1 ) - if $self->connection->is_selected and $mailbox eq $self->connection->selected; - $self->ok_command("[APPENDUID @{[$mailbox->uidvalidity]} @{[$msg->uid]}] APPEND COMPLETED"); - } else { - $self->no_command("Permission denied"); - } -} - -1; diff --git a/inc/Net/IMAP/Server/Command/Authenticate.pm b/inc/Net/IMAP/Server/Command/Authenticate.pm deleted file mode 100644 index 6b72730..0000000 --- a/inc/Net/IMAP/Server/Command/Authenticate.pm +++ /dev/null @@ -1,70 +0,0 @@ -package Net::IMAP::Server::Command::Authenticate; - -use warnings; -use strict; - -use MIME::Base64; -use base qw/Net::IMAP::Server::Command/; - -__PACKAGE__->mk_accessors(qw(sasl pending_auth)); - -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 < 1; - return $self->bad_command("Too many options") if @options > 2; - - return $self->no_command("Login is disabled") - unless $self->connection->capability =~ /\bAUTH=$options[0]\b/i; - - return 1; -} - -sub run { - my $self = shift; - - my($type, $arg) = $self->parsed_options; - $self->server->auth_class->require || $self->log( 1, $@ ); - my $auth = $self->server->auth_class->new; - if ( grep {uc $type eq uc $_} $auth->sasl_provides ) { - $type = lc $type; - my $function = "sasl_$type"; - $self->sasl( $auth->$function() ); - $self->pending_auth($auth); - $self->connection->pending(sub {$self->continue(@_)}); - $self->continue( $arg || ""); - } else { - $self->bad_command("Invalid login"); - } -} - -sub continue { - my $self = shift; - my $line = shift; - - if ( not defined $line or $line =~ /^\*[\r\n]+$/ ) { - $self->connection->pending(undef); - $self->bad_command("Login cancelled"); - return; - } - - $line = decode_base64($line); - - my $response = $self->sasl->($line); - if ( ref $response ) { - $self->out( "+ " . encode_base64($$response) ); - } elsif ($response) { - $self->connection->pending(undef); - $self->connection->auth( $self->pending_auth ); - $self->ok_completed(); - } else { - $self->connection->pending(undef); - $self->bad_command("Invalid login"); - } -} - -1; diff --git a/inc/Net/IMAP/Server/Command/Capability.pm b/inc/Net/IMAP/Server/Command/Capability.pm deleted file mode 100644 index 5aa210b..0000000 --- a/inc/Net/IMAP/Server/Command/Capability.pm +++ /dev/null @@ -1,23 +0,0 @@ -package Net::IMAP::Server::Command::Capability; - -use warnings; -use strict; - -use base qw/Net::IMAP::Server::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->connection->capability ); - $self->ok_completed; -} - -1; diff --git a/inc/Net/IMAP/Server/Command/Check.pm b/inc/Net/IMAP/Server/Command/Check.pm deleted file mode 100644 index 44914f7..0000000 --- a/inc/Net/IMAP/Server/Command/Check.pm +++ /dev/null @@ -1,27 +0,0 @@ -package Net::IMAP::Server::Command::Check; - -use warnings; -use strict; - -use base qw/Net::IMAP::Server::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; - - my @options = $self->parsed_options; - return $self->bad_command("Too many options") if @options; - - return 1; -} - -sub run { - my $self = shift; - $self->connection->poll; - $self->ok_completed(); -} - -1; diff --git a/inc/Net/IMAP/Server/Command/Close.pm b/inc/Net/IMAP/Server/Command/Close.pm deleted file mode 100644 index dc3d444..0000000 --- a/inc/Net/IMAP/Server/Command/Close.pm +++ /dev/null @@ -1,30 +0,0 @@ -package Net::IMAP::Server::Command::Close; - -use warnings; -use strict; - -use base qw/Net::IMAP::Server::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("Too many options") if @options; - - return 1; -} - -sub run { - my $self = shift; - - $self->connection->selected->expunge unless $self->connection->selected->read_only; - $self->connection->selected(undef); - - $self->ok_completed(); -} - -1; diff --git a/inc/Net/IMAP/Server/Command/Copy.pm b/inc/Net/IMAP/Server/Command/Copy.pm deleted file mode 100644 index f4a4d47..0000000 --- a/inc/Net/IMAP/Server/Command/Copy.pm +++ /dev/null @@ -1,48 +0,0 @@ -package Net::IMAP::Server::Command::Copy; - -use warnings; -use strict; - -use base qw/Net::IMAP::Server::Command/; - -use Coro; - -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; - - my @new; - for my $m (@messages) { - push @new, $m->copy($mailbox); - cede; - } - my $sequence = join(",",map {$_->uid} @messages); - my $uids = join(",",map {$_->uid} @new); - $self->ok_command("[COPYUID @{[$mailbox->uidvalidity]} $sequence $uids] COPY COMPLETED"); -} - -1; diff --git a/inc/Net/IMAP/Server/Command/Create.pm b/inc/Net/IMAP/Server/Command/Create.pm deleted file mode 100644 index 67a2c97..0000000 --- a/inc/Net/IMAP/Server/Command/Create.pm +++ /dev/null @@ -1,54 +0,0 @@ -package Net::IMAP::Server::Command::Create; - -use warnings; -use strict; - -use base qw/Net::IMAP::Server::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 already exists") if $mailbox; - - # This both ensures that the mailbox path is valid UTF-7, and that - # there aren't bogusly encoded characters (like '/' -> '&AC8-') - my $roundtrip = eval { - Encode::encode( 'IMAP-UTF-7', - Encode::decode( 'IMAP-UTF-7', $options[0] ) ); - }; - - return $self->bad_command("Invalid UTF-7 encoding") - unless $roundtrip eq $options[0]; - - return 1; -} - -sub run { - my $self = shift; - - my @parts = $self->connection->model->split( $self->parsed_options ); - - my $base = $self->connection->model->root; - for my $n (0.. $#parts) { - my $sep = $self->connection->model->root->separator || ""; - my $path = join($sep, @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(); -} - -1; diff --git a/inc/Net/IMAP/Server/Command/Delete.pm b/inc/Net/IMAP/Server/Command/Delete.pm deleted file mode 100644 index c832b7e..0000000 --- a/inc/Net/IMAP/Server/Command/Delete.pm +++ /dev/null @@ -1,34 +0,0 @@ -package Net::IMAP::Server::Command::Delete; - -use warnings; -use strict; - -use base qw/Net::IMAP::Server::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; diff --git a/inc/Net/IMAP/Server/Command/Examine.pm b/inc/Net/IMAP/Server/Command/Examine.pm deleted file mode 100644 index f2cc40f..0000000 --- a/inc/Net/IMAP/Server/Command/Examine.pm +++ /dev/null @@ -1,11 +0,0 @@ -package Net::IMAP::Server::Command::Examine; - -use warnings; -use strict; - -use base qw/Net::IMAP::Server::Command::Select/; - -# See Net::IMAP::Server::Command::Select, which special-cases the -# "Examine" command to force the mailbox read-only - -1; diff --git a/inc/Net/IMAP/Server/Command/Expunge.pm b/inc/Net/IMAP/Server/Command/Expunge.pm deleted file mode 100644 index 851c8c3..0000000 --- a/inc/Net/IMAP/Server/Command/Expunge.pm +++ /dev/null @@ -1,31 +0,0 @@ -package Net::IMAP::Server::Command::Expunge; - -use warnings; -use strict; - -use base qw/Net::IMAP::Server::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; - - return $self->bad_command("Mailbox is read-only") if $self->connection->selected->read_only; - - my @options = $self->parsed_options; - return $self->bad_command("Too many options") if @options; - - return 1; -} - -sub run { - my $self = shift; - - $self->connection->selected->expunge; - - $self->ok_completed(); -} - -1; diff --git a/inc/Net/IMAP/Server/Command/Fetch.pm b/inc/Net/IMAP/Server/Command/Fetch.pm deleted file mode 100644 index da1ea21..0000000 --- a/inc/Net/IMAP/Server/Command/Fetch.pm +++ /dev/null @@ -1,45 +0,0 @@ -package Net::IMAP::Server::Command::Fetch; - -use warnings; -use strict; - -use base qw/Net::IMAP::Server::Command/; - -use Coro; - -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->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->get_messages($messages); - for my $m (@messages) { - $self->untagged_response( $self->connection->sequence($m) - . " FETCH " - . $self->data_out( [ $m->fetch($spec) ] ) ); - cede; - } - - $self->ok_completed(); -} - -sub send_untagged { - my $self = shift; - - $self->SUPER::send_untagged( expunged => 0 ); -} - -1; diff --git a/inc/Net/IMAP/Server/Command/Id.pm b/inc/Net/IMAP/Server/Command/Id.pm deleted file mode 100644 index caf1f73..0000000 --- a/inc/Net/IMAP/Server/Command/Id.pm +++ /dev/null @@ -1,31 +0,0 @@ -package Net::IMAP::Server::Command::Id; - -use warnings; -use strict; - -use base qw/Net::IMAP::Server::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; - return $self->bad_command("Argument must be a list or NIL") unless $options[0] eq "NIL" - or ref $options[0] eq "ARRAY"; - - return 1; -} - -sub run { - my $self = shift; - - my @options = $self->parsed_options; - $options[0] = [] if $options[0] eq "NIL"; - $self->connection->client_id(@{$options[0]}); - $self->untagged_response("ID " . $self->data_out([$self->server->id])); - - $self->ok_completed(); -} - -1; diff --git a/inc/Net/IMAP/Server/Command/List.pm b/inc/Net/IMAP/Server/Command/List.pm deleted file mode 100644 index e0ede35..0000000 --- a/inc/Net/IMAP/Server/Command/List.pm +++ /dev/null @@ -1,78 +0,0 @@ -package Net::IMAP::Server::Command::List; - -use warnings; -use strict; - -use base qw/Net::IMAP::Server::Command/; - -use Encode; -use Encode::IMAPUTF7; - -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; - - return 1; -} - -sub run { - my $self = shift; - - my ( $root, $search ) = $self->parsed_options; - - # In the special case of a query for the delimiter, give them our delimiter - if ( $search eq "" ) { - my $sep = (defined $self->connection->model->root->separator) - ? q{"}.$self->connection->model->root->separator.q{"} : "NIL"; - $self->tagged_response( qq|(\\Noselect) $sep ""| ); - } else { - my $sep = $self->connection->model->root->separator; - $search = quotemeta($search); - $search =~ s/\\\*/.*/g; - if (defined $sep) { - $search =~ s/\\%/[^$sep]*/g; - } else { - $search =~ s/\\%/.*/g; - } - my $regex = qr{^\Q$root\E$search$}; - $self->connection->model->root->update_tree; - $self->traverse( $self->connection->model->root, $regex ); - } - - $self->ok_completed; -} - -sub list_out { - my $self = shift; - my $node = shift; - my @props = @_; - - my $sep = (defined $self->connection->model->root->separator) - ? q{"}.$self->connection->model->root->separator.q{"} : "NIL"; - my $name = q{"}.Encode::encode('IMAP-UTF-7',$node->full_path).q{"}; - - my $str = $self->data_out([map {\$_} @props]) . " $sep $name"; - $self->tagged_response($str); -} - -sub traverse { - my $self = shift; - my $node = shift; - my $regex = shift; - - my @props; - push @props, @{$node->children} ? '\HasChildren' : '\HasNoChildren'; - push @props, '\Noinferiors' unless defined $self->connection->model->root->separator; - push @props, '\Noselect' unless $node->is_selectable; - - $self->list_out($node, @props) if $node->parent and - Encode::encode('IMAP-UTF-7',$node->full_path) =~ $regex; - $self->traverse( $_, $regex ) for @{ $node->children }; -} - -1; diff --git a/inc/Net/IMAP/Server/Command/Login.pm b/inc/Net/IMAP/Server/Command/Login.pm deleted file mode 100644 index 3d12787..0000000 --- a/inc/Net/IMAP/Server/Command/Login.pm +++ /dev/null @@ -1,39 +0,0 @@ -package Net::IMAP::Server::Command::Login; - -use warnings; -use strict; - -use base qw/Net::IMAP::Server::Command/; - -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 $self->no_command("Login is disabled") - if $self->connection->capability =~ /\bLOGINDISABLED\b/; - - return 1; -} - -sub run { - my $self = shift; - - $self->server->auth_class->require || $self->log( 1, $@ ); - my $auth = $self->server->auth_class->new; - if ( $auth->provides_plain - and $auth->auth_plain( $self->parsed_options ) ) - { - $self->connection->auth($auth); - $self->ok_completed(); - } else { - $self->bad_command("Invalid login"); - } -} - -1; diff --git a/inc/Net/IMAP/Server/Command/Logout.pm b/inc/Net/IMAP/Server/Command/Logout.pm deleted file mode 100644 index 8aea2b1..0000000 --- a/inc/Net/IMAP/Server/Command/Logout.pm +++ /dev/null @@ -1,27 +0,0 @@ -package Net::IMAP::Server::Command::Logout; - -use warnings; -use strict; - -use base qw/Net::IMAP::Server::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(); -} - -sub poll_after { 0 } - -1; diff --git a/inc/Net/IMAP/Server/Command/Lsub.pm b/inc/Net/IMAP/Server/Command/Lsub.pm deleted file mode 100644 index 8c8fa7c..0000000 --- a/inc/Net/IMAP/Server/Command/Lsub.pm +++ /dev/null @@ -1,27 +0,0 @@ -package Net::IMAP::Server::Command::Lsub; - -use warnings; -use strict; - -use base qw/Net::IMAP::Server::Command::List/; - -sub traverse { - my $self = shift; - my $node = shift; - my $regex = shift; - - $self->list_out($node) if $node->parent and $node->full_path =~ $regex and $node->subscribed; - my @kids = grep {$_} map {$self->traverse( $_, $regex )} @{ $node->children }; - if (@kids and $node->parent and not $node->subscribed) { - if ($node->full_path =~ $regex) { - $self->list_out($node, '\NoSelect'); - return 0; - } else { - return 1; - } - } - return 1 if $node->parent and not $node->full_path =~ $regex and $node->subscribed; - return 0; -} - -1; diff --git a/inc/Net/IMAP/Server/Command/Namespace.pm b/inc/Net/IMAP/Server/Command/Namespace.pm deleted file mode 100644 index cb231d4..0000000 --- a/inc/Net/IMAP/Server/Command/Namespace.pm +++ /dev/null @@ -1,33 +0,0 @@ -package Net::IMAP::Server::Command::Namespace; - -use warnings; -use strict; - -use base qw/Net::IMAP::Server::Command/; - -sub validate { - my $self = shift; - - return $self->bad_command("Login first") if $self->connection->is_unauth; - - my @options = $self->parsed_options; - return $self->bad_command("Too many options") if @options; - - return 1; -} - -sub run { - my $self = shift; - - my @namespaces = $self->connection->model->namespaces; - @namespaces = map { - ref($_) eq "ARRAY" - ? "(" . join( "", map { $self->data_out($_) } @{$_} ) . ")" - : $self->data_out($_) - } @namespaces; - $self->untagged_response(join(" ", NAMESPACE => @namespaces)); - - $self->ok_completed(); -} - -1; diff --git a/inc/Net/IMAP/Server/Command/Noop.pm b/inc/Net/IMAP/Server/Command/Noop.pm deleted file mode 100644 index 3f81f0b..0000000 --- a/inc/Net/IMAP/Server/Command/Noop.pm +++ /dev/null @@ -1,23 +0,0 @@ -package Net::IMAP::Server::Command::Noop; - -use warnings; -use strict; - -use base qw/Net::IMAP::Server::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(); -} - -1; diff --git a/inc/Net/IMAP/Server/Command/Rename.pm b/inc/Net/IMAP/Server/Command/Rename.pm deleted file mode 100644 index fa9f2ee..0000000 --- a/inc/Net/IMAP/Server/Command/Rename.pm +++ /dev/null @@ -1,53 +0,0 @@ -package Net::IMAP::Server::Command::Rename; - -use warnings; -use strict; - -use base qw/Net::IMAP::Server::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 $sep = $self->connection->model->root->separator || ""; - my $path = join($sep, @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, $newname) or return $self->no_command("Permission denied"); - - $self->ok_completed(); -} - -1; diff --git a/inc/Net/IMAP/Server/Command/Search.pm b/inc/Net/IMAP/Server/Command/Search.pm deleted file mode 100644 index c0b4010..0000000 --- a/inc/Net/IMAP/Server/Command/Search.pm +++ /dev/null @@ -1,206 +0,0 @@ -package Net::IMAP::Server::Command::Search; - -use warnings; -use strict; -use bytes; - -use base qw/Net::IMAP::Server::Command/; -use DateTime::Format::Strptime; - -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; - - return 1; -} - -sub run { - my $self = shift; - - my $filter = $self->filter($self->parsed_options); - return unless $filter; - - my @results = map {$self->connection->sequence($_)} grep {$filter->($_)} $self->connection->get_messages('1:*'); - $self->untagged_response(join(" ", SEARCH => @results)); - $self->ok_completed; -} - -my $arg_parser = DateTime::Format::Strptime->new(pattern => "%e-%b-%Y"); - -sub filter { - my $self = shift; - my @tokens = [@_]; # This ref is intentional! It gets us the top-level AND - my $filters = []; my @stack; - # TODO: CHARSET support - while (@tokens) { - my $token = shift @tokens; - $token = uc $token unless ref $token; - if ($token eq "ALL") { - push @{$filters}, sub {1}; - } elsif ($token eq "ANSWERED") { - push @{$filters}, sub {$_[0]->has_flag('\Answered')}; - } elsif ($token eq "BCC") { - return $self->bad_command("Parse error") unless @tokens; - my $bcc = shift @tokens; - push @{$filters}, sub {$_[0]->mime->header("Bcc")||"" =~ /\Q$bcc\E/i}; - } elsif ($token eq "BEFORE") { - return $self->bad_command("Parse error") unless @tokens; - my $date = shift @tokens; - my $parsed = $arg_parser->parse_datetime($date); - return $self->bad_command("Bad date: $date") unless $parsed; - push @{$filters}, sub {$_[0]->epoch_day_utc < $parsed->epoch }; - } elsif ($token eq "BODY") { - return $self->bad_command("Parse error") unless @tokens; - my $str = shift @tokens; - push @{$filters}, sub {$_[0]->mime->body =~ /\Q$str\E/i}; # TODO: likely needs to recurse MIME parts? - } elsif ($token eq "CC") { - return $self->bad_command("Parse error") unless @tokens; - my $cc = shift @tokens; - push @{$filters}, sub {$_[0]->mime->header("Cc")||"" =~ /\Q$cc\E/i}; - } elsif ($token eq "DELETED") { - push @{$filters}, sub {$_[0]->has_flag('\Deleted')}; - } elsif ($token eq "DRAFT") { - push @{$filters}, sub {$_[0]->has_flag('\Draft')}; - } elsif ($token eq "FLAGGED") { - push @{$filters}, sub {$_[0]->has_flag('\Flagged')}; - } elsif ($token eq "FROM") { - return $self->bad_command("Parse error") unless @tokens; - my $from = shift @tokens; - push @{$filters}, sub {$_[0]->mime->header("From")||"" =~ /\Q$from\E/i}; - } elsif ($token eq "HEADER") { - return $self->bad_command("Parse error") unless @tokens >= 2; - my ($header, $value) = splice(@tokens, 0, 2); - push @{$filters}, sub {$_[0]->mime->header($header)||"" =~ /\Q$value\E/i}; - } elsif ($token eq "KEYWORD") { - return $self->bad_command("Parse error") unless @tokens; - my $keyword = shift @tokens; - push @{$filters}, sub {$_[0]->has_flag($keyword)}; - } elsif ($token eq "LARGER") { - return $self->bad_command("Parse error") unless @tokens; - my $size = shift @tokens; - push @{$filters}, sub {length $_[0]->mime->as_string > $size}; - } elsif ($token eq "NEW") { - push @{$filters}, sub {$_[0]->has_flag('\Recent') and not $_->has_flag('\Seen')}; - } elsif ($token eq "NOT") { - unshift @stack, [NOT => 1 => $filters]; - my $negation = []; - push @{$filters}, sub {not $negation->[0]->(@_)}; - $filters = $negation; - } elsif ($token eq "OLD") { - push @{$filters}, sub {not $_[0]->has_flag('\Recent')}; - } elsif ($token eq "ON") { - return $self->bad_command("Parse error") unless @tokens; - my $date = shift @tokens; - my $parsed = $arg_parser->parse_datetime($date); - return $self->bad_command("Bad date: $date") unless $parsed; - push @{$filters}, sub {$_[0]->epoch_day_utc >= $parsed->epoch and $_[0]->epoch_day_utc < $parsed->epoch + 60*60*24 }; - } elsif ($token eq "OR") { - unshift @stack, [OR => 2 => $filters]; - my $union = []; - push @{$filters}, sub {$union->[0]->(@_) or $union->[1]->(@_)}; - $filters = $union; - } elsif ($token eq "RECENT") { - push @{$filters}, sub {$_[0]->has_flag('\Recent')}; - } elsif ($token eq "SEEN") { - push @{$filters}, sub {$_[0]->has_flag('\Seen')}; - } elsif ($token eq "SENTBEFORE") { - return $self->bad_command("Parse error") unless @tokens; - my $date = shift @tokens; - my $parsed = $arg_parser->parse_datetime($date); - return $self->bad_command("Bad date: $date") unless $parsed; - push @{$filters}, sub {my $e = $_[0]->date_day_utc; defined $e and $e->epoch < $parsed->epoch; }; - } elsif ($token eq "SENTON") { - return $self->bad_command("Parse error") unless @tokens; - my $date = shift @tokens; - my $parsed = $arg_parser->parse_datetime($date); - return $self->bad_command("Bad date: $date") unless $parsed; - push @{$filters}, sub {my $e = $_[0]->date_day_utc; defined $e and $e->epoch >= $parsed->epoch and $e->epoch < $parsed->epoch + 60*60*24 }; - } elsif ($token eq "SENTSINCE") { - return $self->bad_command("Parse error") unless @tokens; - my $date = shift @tokens; - my $parsed = $arg_parser->parse_datetime($date); - return $self->bad_command("Bad date: $date") unless $parsed; - push @{$filters}, sub {my $e = $_[0]->date_day_utc; defined $e and $e->epoch >= $parsed->epoch }; - } elsif ($token eq "SINCE") { - return $self->bad_command("Parse error") unless @tokens; - my $date = shift @tokens; - my $parsed = $arg_parser->parse_datetime($date); - return $self->bad_command("Bad date: $date") unless $parsed; - push @{$filters}, sub {$_[0]->epoch_day_utc >= $parsed->epoch } - } elsif ($token eq "SMALLER") { - return $self->bad_command("Parse error") unless @tokens; - my $size = shift @tokens; - push @{$filters}, sub {length $_[0]->mime->as_string < $size}; - } elsif ($token eq "SUBJECT") { - return $self->bad_command("Parse error") unless @tokens; - my $subj = shift @tokens; - push @{$filters}, sub {$_[0]->mime->header("Subject") =~ /\Q$subj\E/i}; - } elsif ($token eq "TEXT") { - return $self->bad_command("Parse error") unless @tokens; - my $str = shift @tokens; - push @{$filters}, sub {$_[0]->mime->as_string =~ /\Q$str\E/i}; - } elsif ($token eq "TO") { - return $self->bad_command("Parse error") unless @tokens; - my $to = shift @tokens; - push @{$filters}, sub {$_[0]->mime->header("To")||"" =~ /\Q$to\E/i}; - } elsif ($token eq "UID") { - return $self->bad_command("Parse error") unless @tokens; - my $set = shift @tokens; - my %uids; - $uids{$_->uid}++ for $self->connection->selected->get_uids($set); - push @{$filters}, sub {$uids{$_[0]->uid}}; - } elsif ($token eq "UNANSWERED") { - push @{$filters}, sub {not $_[0]->has_flag('\Answered')}; - } elsif ($token eq "UNDELETED") { - push @{$filters}, sub {not $_[0]->has_flag('\Deleted')}; - } elsif ($token eq "UNDRAFT") { - push @{$filters}, sub {not $_[0]->has_flag('\Draft')}; - } elsif ($token eq "UNFLAGGED") { - push @{$filters}, sub {not $_[0]->has_flag('\Flagged')}; - } elsif ($token eq "UNKEYWORD") { - return $self->bad_command("Parse error") unless @tokens; - my $keyword = shift @tokens; - push @{$filters}, sub {not $_[0]->has_flag($keyword)}; - } elsif ($token eq "UNSEEN") { - push @{$filters}, sub {not $_[0]->has_flag('\Seen')}; - } elsif ($token =~ /^\d+(:\d+|:\*)?(,\d+(:\d+|:\*)?)*$/) { - my %uids; - $uids{$_->uid}++ for $self->connection->get_messages($token); - push @{$filters}, sub {$uids{$_[0]->uid}}; - } elsif (ref $token) { - unshift @stack, [AND => -1 => $filters, \@tokens]; - @tokens = @{$token}; - my $intersection = []; - push @{$filters}, sub { - for my $f (@{$intersection}) { - return unless $f->(@_); - } - return 1; - }; - $filters = $intersection; - } else { - return $self->bad_command("Unknown search token: $token"); - } - - while (@stack and (@{$filters} == $stack[0][1] or ($stack[0][3] and not @tokens))) { - $filters = $stack[0][2]; - @tokens = @{$stack[0][3]} if $stack[0][3]; - shift @stack; - } - } - - return $self->bad_command("Unclosed NOT/OR") if @stack; - - return shift @{$filters}; -} - -sub send_untagged { - my $self = shift; - - $self->SUPER::send_untagged( expunged => 0 ); -} - -1; diff --git a/inc/Net/IMAP/Server/Command/Select.pm b/inc/Net/IMAP/Server/Command/Select.pm deleted file mode 100644 index e746a8d..0000000 --- a/inc/Net/IMAP/Server/Command/Select.pm +++ /dev/null @@ -1,61 +0,0 @@ -package Net::IMAP::Server::Command::Select; - -use warnings; -use strict; - -use base qw/Net::IMAP::Server::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 does not exist") unless $mailbox; - return $self->no_command("Mailbox is not selectable") unless $mailbox->is_selectable; - - return 1; -} - -sub run { - my $self = shift; - - my $mailbox = $self->connection->model->lookup( $self->parsed_options ); - $mailbox->poll; - $self->connection->last_poll(time); - $self->connection->selected($mailbox, $self->command eq "Examine"); - - $self->untagged_response( - 'FLAGS (' . join( ' ', $mailbox->flags ) . ')' ); - $self->untagged_response( $mailbox->exists . ' EXISTS' ); - $self->untagged_response( $mailbox->recent . ' RECENT' ); - - my $unseen = $mailbox->first_unseen; - $self->untagged_response("OK [UNSEEN $unseen]"); - - my $uidvalidity = $mailbox->uidvalidity; - $self->untagged_response("OK [UIDVALIDITY $uidvalidity]") - if defined $uidvalidity; - - my $uidnext = $mailbox->uidnext; - $self->untagged_response("OK [UIDNEXT $uidnext]") if defined $uidnext; - - my $permanentflags = $mailbox->permanentflags; - $self->untagged_response( "OK [PERMANENTFLAGS (" - . join( ' ', $mailbox->permanentflags ) - . ')]' ); - - if ( $mailbox->read_only ) { - $self->ok_command("[READ-ONLY] Completed"); - } else { - $self->ok_command("[READ-WRITE] Completed"); - } -} - -sub poll_after { 0 } - -1; diff --git a/inc/Net/IMAP/Server/Command/Starttls.pm b/inc/Net/IMAP/Server/Command/Starttls.pm deleted file mode 100644 index 020e6ef..0000000 --- a/inc/Net/IMAP/Server/Command/Starttls.pm +++ /dev/null @@ -1,31 +0,0 @@ -package Net::IMAP::Server::Command::Starttls; - -use warnings; -use strict; - -use base qw/Net::IMAP::Server::Command/; - -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("Too many options") if @options; - - return $self->no_command("STARTTLS is disabled") - unless $self->connection->capability =~ /\bSTARTTLS\b/; - - return 1; -} - -sub run { - my $self = shift; - - $self->ok_completed; - - $self->connection->io_handle->start_SSL; -} - -1; diff --git a/inc/Net/IMAP/Server/Command/Status.pm b/inc/Net/IMAP/Server/Command/Status.pm deleted file mode 100644 index 7bc57c6..0000000 --- a/inc/Net/IMAP/Server/Command/Status.pm +++ /dev/null @@ -1,39 +0,0 @@ -package Net::IMAP::Server::Command::Status; - -use warnings; -use strict; - -use base qw/Net::IMAP::Server::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 ( $name, $flags ) = @options; - return $self->bad_command("Wrong second option") unless ref $flags; - - my $mailbox = $self->connection->model->lookup( $name ); - return $self->no_command("Mailbox does not exist") unless $mailbox; - return $self->no_command("Mailbox is not selectable") unless $mailbox->is_selectable; - - return 1; -} - -sub run { - my $self = shift; - - my ( $name, $flags ) = $self->parsed_options; - my $mailbox = $self->connection->model->lookup( $name ); - - my %items = $mailbox->status(map {uc $_} @{$flags}); - $self->untagged_response( "STATUS ".$self->data_out({type=>"string", value => $name}) . " " - . $self->data_out([map {(\$_, $items{$_})}keys %items]) ); - $self->ok_completed; -} - -1; diff --git a/inc/Net/IMAP/Server/Command/Store.pm b/inc/Net/IMAP/Server/Command/Store.pm deleted file mode 100644 index 2cbc44d..0000000 --- a/inc/Net/IMAP/Server/Command/Store.pm +++ /dev/null @@ -1,51 +0,0 @@ -package Net::IMAP::Server::Command::Store; - -use warnings; -use strict; - -use base qw/Net::IMAP::Server::Command/; - -use Coro; - -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; - - return $self->bad_command("Mailbox is read-only") if $self->connection->selected->read_only; - - 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 = ref $flags ? $flags : [$flags]; - - return $self->bad_command("Invalid flag $_") for grep {not $self->connection->selected->can_set_flag($_)} @{$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 ); - cede; - } - $self->connection->ignore_flags(0) if $what =~ /\.SILENT$/i; - - $self->ok_completed(); -} - -sub send_untagged { - my $self = shift; - - $self->SUPER::send_untagged( expunged => 0 ); -} - -1; diff --git a/inc/Net/IMAP/Server/Command/Subscribe.pm b/inc/Net/IMAP/Server/Command/Subscribe.pm deleted file mode 100644 index b0cf537..0000000 --- a/inc/Net/IMAP/Server/Command/Subscribe.pm +++ /dev/null @@ -1,32 +0,0 @@ -package Net::IMAP::Server::Command::Subscribe; - -use warnings; -use strict; - -use base qw/Net::IMAP::Server::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 does not exist") unless $mailbox; - - return 1; -} - -sub run { - my $self = shift; - - my $mailbox = $self->connection->model->lookup( $self->parsed_options ); - $mailbox->subscribed(1); - - $self->ok_completed(); -} - -1; diff --git a/inc/Net/IMAP/Server/Command/Uid.pm b/inc/Net/IMAP/Server/Command/Uid.pm deleted file mode 100644 index 6a5266e..0000000 --- a/inc/Net/IMAP/Server/Command/Uid.pm +++ /dev/null @@ -1,137 +0,0 @@ -package Net::IMAP::Server::Command::Uid; - -use warnings; -use strict; - -use base qw/Net::IMAP::Server::Command/; -use Net::IMAP::Server::Command::Search; - -use Coro; - -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->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|expunge)$/i ) { - $self->$subcommand(@rest); - } else { - $self->log( - $subcommand . " wasn't understood by the 'UID' command" ); - $self->no_failed( - alert => q{Your client sent a UID command we didn't understand} ); - } - -} - -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}; - my @messages = $self->connection->selected->get_uids($messages); - for my $m (@messages) { - $self->untagged_response( $self->connection->sequence($m) - . " FETCH " - . $self->data_out( [ $m->fetch($spec) ] ) ); - cede; - } - - $self->ok_completed(); -} - -sub store { - my $self = shift; - - return $self->bad_command("Mailbox is read-only") if $self->connection->selected->read_only; - - 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]; - - return $self->bad_command("Invalid flag $_") for grep {not $self->connection->selected->can_set_flag($_)} @{$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 ); - $self->connection->_unsent_fetch->{$self->connection->sequence($m)}{UID}++ - unless $what =~ /\.SILENT$/i; - cede; - } - $self->connection->ignore_flags(0) if $what =~ /\.SILENT$/i; - - $self->ok_completed; -} - -sub copy { - my $self = shift; - - 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; - - my @new; - for my $m (@messages) { - push @new, $m->copy($mailbox); - cede; - } - my $sequence = join(",",map {$_->uid} @messages); - my $uids = join(",",map {$_->uid} @new); - $self->ok_command("[COPYUID @{[$mailbox->uidvalidity]} $sequence $uids] COPY COMPLETED"); -} - -sub expunge { - my $self = shift; - - return $self->bad_command("Not enough options") if @_ < 1; - return $self->bad_command("Too many options") if @_ > 2; - - return $self->bad_command("Mailbox is read-only") if $self->connection->selected->read_only; - - my ( $messages ) = @_; - my @messages = $self->connection->selected->get_uids($messages); - $self->connection->selected->expunge([map {$_->sequence} @messages]); - - $self->ok_completed; -} - -sub search { - my $self = shift; - - my $filter = Net::IMAP::Server::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; -} - -1; diff --git a/inc/Net/IMAP/Server/Command/Unsubscribe.pm b/inc/Net/IMAP/Server/Command/Unsubscribe.pm deleted file mode 100644 index 84bfc89..0000000 --- a/inc/Net/IMAP/Server/Command/Unsubscribe.pm +++ /dev/null @@ -1,32 +0,0 @@ -package Net::IMAP::Server::Command::Unsubscribe; - -use warnings; -use strict; - -use base qw/Net::IMAP::Server::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 does not exist") unless $mailbox; - - return 1; -} - -sub run { - my $self = shift; - - my $mailbox = $self->connection->model->lookup( $self->parsed_options ); - $mailbox->subscribed(0); - - $self->ok_completed(); -} - -1; diff --git a/inc/Net/IMAP/Server/Connection.pm b/inc/Net/IMAP/Server/Connection.pm deleted file mode 100644 index 30b473d..0000000 --- a/inc/Net/IMAP/Server/Connection.pm +++ /dev/null @@ -1,638 +0,0 @@ -package Net::IMAP::Server::Connection; - -use warnings; -use strict; - -use base 'Class::Accessor'; - -use Coro; -use Scalar::Util qw/weaken/; - -use Net::IMAP::Server::Error; -use Net::IMAP::Server::Command; - -__PACKAGE__->mk_accessors( - qw(server coro io_handle model auth - timer commands pending - selected_read_only - _selected - - temporary_messages temporary_sequence_map - ignore_flags - _session_flags - - last_poll previous_exists in_poll - _unsent_expunge _unsent_fetch - ) -); - -=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", - _unsent_expunge => [], - _unsent_fetch => {}, - last_poll => time, - commands => 0, - coro => $Coro::current, - _session_flags => {}, - } - ); - $self->update_timer; - return $self; -} - -=head2 server - -Returns the L that this connection is on. - -=head2 coro - -Returns the L process associated with this connection. For -things interacting with this connection, it will probably be the -current coroutine, except for interactions coming from event loops. - -=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 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 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->model_class->require || $self->log(1, $@); - $self->update_timer; - $self->model( - $self->server->model_class->new( { auth => $self->{auth} } ) ); - } - return $self->{auth}; -} - -=head2 client_id - -When called with no arguments, returns a hashref of identifying -information provided by the client. When key-value pairs are -provided, sets the client properties. See RFC 2971. - -=cut - -sub client_id { - my $self = shift; - if (@_ > 1) { - $self->{client} = {%{$self->{client} || {}}, @_}; - } - return $self->{client} || {}; -} - -=head2 selected [MAILBOX], [READ_ONLY] - -Gets or sets the currently selected mailbox for this connection. -Changing mailboxes triggers the sending of untagged notifications to -the client, as well as calling L and -L. - -=cut - -sub selected { - my $self = shift; - my ($mailbox, $read_only) = @_; - - # This is just being called as a getter - return $self->_selected unless @_; - - # This is a setter, but isn't actually changing the mailbox, nor - # changing the read-only-ness. - return $self->_selected if ($mailbox || "") eq ($self->_selected || "") - and ($self->selected_read_only || 0) == ($read_only || 0); - - # Otherwise, flush any untagged messages, close the old, and open - # the new. - $self->send_untagged; - $self->_selected->close if $self->_selected; - $self->_selected( $mailbox ); - if ($self->_selected) { - $self->selected_read_only( $read_only ); - $self->_selected->select; - } - - return $self->_selected; -} - -=head2 selected_read_only - -Returns true of the currently selected mailbox has been forced into -read-only mode. Note that the mailbox may be read-only for other -reasons, so checking L is -suggested instead. - -=head2 greeting - -Sends out a one-line untagged greeting to the client. - -=cut - -sub greeting { - my $self = shift; - $self->untagged_response('OK IMAP4rev1 Server'); -} - -=head2 handle_lines - -The main line handling loop. Since we are using L, 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; - $self->coro->prio(-4); - - eval { - $self->greeting; - while ( $self->io_handle and $_ = $self->io_handle->getline() ) { - $self->handle_command($_); - $self->commands( $self->commands + 1 ); - if ( $self->is_unauth - and $self->server->unauth_commands - and $self->commands >= $self->server->unauth_commands ) - { - $self->out( - "* BYE Don't noodle around so much before logging in!"); - last; - } - $self->update_timer; - cede; - } - - $self->log( 4, - "-(@{[$self]},@{[$self->auth ? $self->auth->user : '???']},@{[$self->is_selected ? $self->selected->full_path : 'unselected']}): Connection closed by remote host" - ); - }; - my $err = $@; - $self->log(1, $err) - if $err and not( $err eq "Error printing\n" or $err eq "Timeout\n" ); - eval { $self->out("* BYE Idle timeout; I fell asleep.") if $err eq "Timeout\n"; }; - $self->close; -} - -=head2 update_timer - -Updates the inactivity timer. - -=cut - -sub update_timer { - my $self = shift; - $self->timer->stop if $self->timer; - $self->timer(undef); - my $weakself = $self; - weaken($weakself); - my $timeout = sub { - $weakself->coro->throw("Timeout\n"); - $weakself->coro->ready; - }; - if ( $self->is_unauth and $self->server->unauth_idle ) { - $self->timer( EV::timer $self->server->unauth_idle, 0, $timeout ); - } elsif ( $self->server->auth_idle ) { - $self->timer( EV::timer $self->server->auth_idle, 0, $timeout ); - } -} - -=head2 timer [EV watcher] - -Returns the L watcher in charge of the inactivity timer. - -=head2 commands - -Returns the number of client commands the connection has processed. - -=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. This also handles dispatch of client commands to -L subclasses (see L). - -Any errors generated while running commands will cause a C to be sent to the client -- unless the error message starts -with C or c, in which case it will be relayed to the client. - -Returns the L instance that was run, or -C if it was a continuation line or pending interactive command. - -=cut - -sub handle_command { - my $self = shift; - my $content = shift; - - my $output = $content; - $output =~ s/[\r\n]+$//; - $self->log( 4, - "C(@{[$self]},@{[$self->auth ? $self->auth->user : '???']},@{[$self->is_selected ? $self->selected->full_path : 'unselected']}): $output" - ); - - if ( $self->pending ) { - $self->pending->($content); - return; - } - - my ( $id, $cmd, $options ) = $self->parse_command($content); - return unless defined $id; - - my $handler = $self->class_for($cmd)->new( - { server => $self->server, - connection => $self, - options_str => $options, - command_id => $id, - command => $cmd - } - ); - return if $handler->has_literal; - - eval { $handler->run() if $handler->validate; }; - if ( my $error = $@ ) { - if ($error eq "Timeout\n" or $error eq "Error printing\n") { - die $error; - } elsif ($error =~ /^NO (.*)/) { - $handler->no_command($1); - } elsif ($error =~ /^BAD (.*)/) { - $handler->bad_command($1); - } else { - $handler->no_command("Server error"); - $self->log(1, $error); - } - } - return $handler; -} - -=head2 class_for COMMAND - -Returns the package name that implements the given C. See -L. - -=cut - -sub class_for { - my $self = shift; - my $cmd = shift; - my $classref = $self->server->command_class; - my $cmd_class = $classref->{lc $cmd} || $classref->{$cmd} || $classref->{uc $cmd} - || "Net::IMAP::Server::Command::$cmd"; - my $class_path = $cmd_class; - $class_path =~ s{::}{/}g; - - $cmd_class->require(); - my $err = $@; - if ($err and $err !~ /^Can't locate $class_path.pm in \@INC/) { - $self->log(1, $@); - $cmd_class = "Net::IMAP::Server::Error"; - } - - return $cmd_class->can('run') ? $cmd_class : "Net::IMAP::Server::Command"; -} - -=head2 pending - -If a connection has pending state, contains the callback that will -receive the next line of input. - -=cut - -=head2 close - -Shuts down this connection, also closing the model and mailboxes. - -=cut - -sub close { - my $self = shift; - if ( $self->io_handle ) { - $self->io_handle->close; - $self->io_handle(undef); - } - $self->timer->stop if $self->timer; - $self->selected->close if $self->selected; - $self->model->close if $self->model; - $self->server->connection(undef); - $self->coro(undef); -} - -=head2 parse_command LINE - -Parses the line into the C, C, and C. Returns -undef if parsing fails for some reason. - -=cut - -sub parse_command { - my $self = shift; - my $line = shift; - $line =~ s/[\r\n]+$//; - my $TAG = qr/([^\(\)\{ \*\%"\\\+}]+)/; - unless ( $line =~ /^$TAG\s+(\w+)(?:\s+(.+?))?$/ ) { - if ( $line !~ /^$TAG\s+/ ) { - $self->out("* BAD Invalid tag"); - } else { - $self->out("* BAD Null command ('$line')"); - } - return undef; - } - - my $id = $1; - my $cmd = $2; - my $args = $3 || ''; - $cmd = ucfirst( lc($cmd) ); - 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; - return $self->io_handle->is_ssl; -} - -=head2 poll - -Polls the currently selected mailbox, and resets the poll timer. - -=cut - -sub poll { - my $self = shift; - $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. - -=head2 previous_exists - -The high-water mark of how many messages the client has been told are -in the mailbox. - -=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, - @_ - ); - return unless $self->is_auth and $self->is_selected; - - if ( time >= $self->last_poll + $self->server->poll_every ) { - # We record that we're in a poll so that EXPUNGE knows that - # this connection should get a temporary message store if need - # be. - $self->in_poll(1); - $self->poll; - $self->in_poll(0); - } - - for my $s ( keys %{ $self->_unsent_fetch } ) { - my ($m) = $self->get_messages($s); - $self->untagged_response( - $s - . " FETCH " - . Net::IMAP::Server::Command->data_out( - [ $m->fetch( [ keys %{ $self->_unsent_fetch->{$s} } ] ) ] - ) - ); - } - $self->_unsent_fetch( {} ); - - if ( $args{expunged} ) { - -# Make sure that they know of at least the existence of what's being expunged. - my $max = 0; - $max = $max < $_ ? $_ : $max for @{ $self->_unsent_expunge }; - $self->untagged_response("$max EXISTS") - if $max > $self->previous_exists; - - # Send the expunges, clear out the temporary message store - $self->previous_exists( - $self->previous_exists - @{ $self->_unsent_expunge } ); - $self->untagged_response( map {"$_ EXPUNGE"} - @{ $self->_unsent_expunge } ); - $self->_unsent_expunge( [] ); - $self->temporary_messages(undef); - } - - # Let them know of more EXISTS - my $expected = $self->previous_exists; - 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; - - my $messages = $self->temporary_messages || $self->selected->messages; - - my %ids; - 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+)$/) { - $ids{$1}++; - } elsif (/^\*$/) { - $ids{ @{$messages} + 0 }++; - } - } - return 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 $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 -capability, and no authentication capabilities. The -L's -L method is used to list -known C types. - -=cut - -sub capability { - my $self = shift; - - my $base = $self->server->capability; - if ( $self->is_encrypted ) { - my $auth = $self->auth || $self->server->auth_class->new; - $base = join( " ", - grep { $_ ne "STARTTLS" } split( ' ', $base ), - map {"AUTH=$_"} $auth->sasl_provides ); - } else { - $base = "$base LOGINDISABLED"; - } - - return $base; -} - -=head2 log SEVERITY, MESSAGE - -Defers to L. - -=cut - -sub log { - my $self = shift; - $self->server->log(@_); -} - -=head2 untagged_response STRING - -Sends an untagged response to the client; a newline ia automatically -appended. - -=cut - -sub untagged_response { - my $self = shift; - $self->out("* $_") for grep defined, @_; -} - -=head2 out STRING - -Sends the message to the client. If the client's connection has -dropped, or the send fails for whatever reason, L the -connection and then die, which is caught by L. - -=cut - -sub out { - my $self = shift; - my $msg = shift; - if ( $self->io_handle and $self->io_handle->peerport ) { - if ( $self->io_handle->print( $msg . "\r\n" ) ) { - $self->log( 4, - "S(@{[$self]},@{[$self->auth ? $self->auth->user : '???']},@{[$self->is_selected ? $self->selected->full_path : 'unselected']}): $msg" - ); - } else { - $self->close; - die "Error printing\n"; - } - } else { - $self->close; - die "Error printing\n"; - } -} - -1; diff --git a/inc/Net/IMAP/Server/DefaultAuth.pm b/inc/Net/IMAP/Server/DefaultAuth.pm deleted file mode 100644 index 3ba2b3c..0000000 --- a/inc/Net/IMAP/Server/DefaultAuth.pm +++ /dev/null @@ -1,114 +0,0 @@ -package Net::IMAP::Server::DefaultAuth; - -use warnings; -use strict; - -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 -command, or the C command. L sends the password -unencrypted; note, however, that L will not allow -the LOGIN command unless the connection is protected by either SSL or -TLS. Thus, even when the C 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, unless they -need to implement other forms of authorization than C or -C. - -=cut - -=head1 METHODS - -=head2 user [VALUE] - -Gets or sets the plaintext username of the authenticated user. - -=head2 provides_plain - -If L returns true (the default), C capability -will be advertised when under a layer, and L will be -called if the user sends the C command. - -=cut - -sub provides_plain { return 1; } - -=head2 auth_plain USER, PASSWORD - -Returns true if the given C is allowed to log in using the -provided C. This should also set L to the username -if login was successful. This path is used by both C and -C commands. - -=cut - -sub auth_plain { - my $self = shift; - my ( $user, $pass ) = @_; - $self->user($user); - return 1; -} - -=head2 sasl_provides - -The C command checks that the provided SASL -authentication type is in the list that L returns. It -defaults to only C. - -=cut - -sub sasl_provides { - my $self = shift; - return ("PLAIN"); -} - -=head2 sasl_plain - -Called when the client requests C SASL authentication. This -parses the SASL protocol, and defers to L 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; - return \"" unless $line; - - my ( $authz, $user, $pass ) = split /\x{0}/, $line, 3; - return $self->auth_plain( $user, $pass ); - }; -} - -=head1 IMPLEMENTING NEW SASL METHODS - -The L method is a simple example of implementing a SASL -protocol, albeit 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 function returns a scalar reference, the scalar will be base-64 -encoded and transmitted to the client. Anything 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 themselves. - -=cut - -1; diff --git a/inc/Net/IMAP/Server/DefaultModel.pm b/inc/Net/IMAP/Server/DefaultModel.pm deleted file mode 100644 index 454b8ab..0000000 --- a/inc/Net/IMAP/Server/DefaultModel.pm +++ /dev/null @@ -1,161 +0,0 @@ -package Net::IMAP::Server::DefaultModel; - -use warnings; -use strict; - -use base 'Class::Accessor'; -__PACKAGE__->mk_accessors(qw(auth root)); - -use Net::IMAP::Server::Mailbox; - -use Encode; -use Encode::IMAPUTF7; - -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 to set up their folder -structure. - -Methods in the model can C with messages which start with "NO" or -"BAD", which will be propagated back to the client immediately. See -L. - -=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(@_); - $self->init; - return $self; -} - -=head2 init - -Called when the class is instantiated, with no arguments. Subclasses -should override this method to inspect the L object, and -determine what folders the user should have. The primary purpose of -this method is to set L to the top level of the mailbox tree. -The root is expected to contain a mailbox named C. - -=cut - -sub init { - my $self = shift; - my $user = $self->auth->user || 'default'; - - if ( $roots{$user} ) { - $self->root( $roots{$user} ); - } else { - $self->root( Net::IMAP::Server::Mailbox->new() ) - ->add_child( name => "INBOX" ) - ->add_child( name => $user ); - $roots{$user} = $self->root; - } - - return $self; -} - -=head2 root MAILBOX - -Gets or sets the root L for this model. -The root mailbox should contain no messages, and have no name -- it -exists purely to contain sub-mailboxes, like C. The L -method is responsible for setting up the appropriate root mailbox, and -all sub-mailboxes for the model. - -=head2 auth - -Returns the L object for this model; -this is set by the connection when the model is created, and will -always reference a valid authentication object. - -=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 according to the mailbox -separator, as determined by the -L of the L. May C -if the path (which is expected to be encoded using IMAP-UTF-7) is -invalid. See L. If the mailbox hierarchy is flat -(i.e. the separator is undef), returns the name without change. - -=cut - -sub split { - my $self = shift; - my $name = shift; - - $name = eval { Encode::decode('IMAP-UTF-7', $name) }; - die "BAD Invalid UTF-7 encoding\n" unless defined $name; - - if (defined $self->root->separator) { - return grep {length} split quotemeta $self->root->separator, $name; - } else { - return $name; - } -} - -=head2 lookup PATH - -Given a C, returns the L 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; - 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 }; - return undef unless @match; - $part = $match[0]; - } - return $part; -} - -=head2 namespaces - -Returns the namespaces of this model, per RFC 2342. Defaults to -"INBOX" being the personal namespace, with no "shared" or "other -users" namespaces. - -=cut - -sub namespaces { - my $self = shift; - return ([["" => $self->root->separator]], undef, undef); -} - -1; diff --git a/inc/Net/IMAP/Server/Error.pm b/inc/Net/IMAP/Server/Error.pm deleted file mode 100644 index e54d863..0000000 --- a/inc/Net/IMAP/Server/Error.pm +++ /dev/null @@ -1,33 +0,0 @@ -package Net::IMAP::Server::Error; - -use warnings; -use strict; - -use base qw/Net::IMAP::Server::Command/; - -=head1 NAME - -Net::IMAP::Server::Error - A command which failed catastrophically - -=head1 DESCRIPTION - -A subclass of L used when the true command -fails to compile or load, for whatever reason. This is intentionally -not C, as that would make it -available to clients as the C command. - -=head1 METHODS - -=head2 run - -Produces a server error. - -=cut - -sub run { - my $self = shift; - - $self->no_command("Server error"); -} - -1; diff --git a/inc/Net/IMAP/Server/Mailbox.pm b/inc/Net/IMAP/Server/Mailbox.pm deleted file mode 100644 index 8c78eda..0000000 --- a/inc/Net/IMAP/Server/Mailbox.pm +++ /dev/null @@ -1,688 +0,0 @@ -package Net::IMAP::Server::Mailbox; - -use warnings; -use strict; - -use Net::IMAP::Server::Message; -use base 'Class::Accessor'; - -__PACKAGE__->mk_accessors( - qw(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 if a mailbox with the same -full path already exists. It calls L, then L. - -=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 }; - $self->is_inbox(1) - if $self->parent - and not $self->parent->parent - and $self->name =~ /^inbox$/i; - $self->init; - $self->load_data; - return $self; -} - -=head3 init - -Sets up basic properties of the mailbox: - -=over - -=item * - -L is set to 1000 - -=item * - -L and L are initialized to an empty list reference -and an empty hash reference, respectively. - -=item * - -L is set to an empty list reference. - -=item * - -L is set to the number of seconds since the epoch. - -=item * - -L and L are set true. - -=back - -=cut - -sub init { - my $self = shift; - $self->uidnext(1000); - $self->messages( [] ); - $self->uids( {} ); - $self->children( [] ); - $self->uidvalidity(time); - $self->subscribed(1); - $self->is_selectable(1); -} - -=head3 load_data - -This default mailbox implementation simply returns an empty mailbox. -Subclasses will probably wish to override this method. - -=cut - -sub load_data { -} - -=head3 name - -Gets or sets the name of the mailbox. This includes a workaround for -Zimbra, which doesn't understand mailbox names with colons in them -- -so we substitute dashes. - -=cut - -sub name { - my $self = shift; - if (@_) { - $self->{name} = shift; - } - - # Zimbra can't handle mailbox names with colons in them, for no - # obvious reason. Handily, it identifies itself as Zimbra before - # login, so we know when to perform a colonoscopy. We do this on - # get, and not on set, because the same model might be used by - # other clients. - my $name = $self->{name}; - $name =~ s/:+/-/g - if Net::IMAP::Server->connection - and exists Net::IMAP::Server->connection->client_id->{vendor} - and Net::IMAP::Server->connection->client_id->{vendor} eq "Zimbra"; - - return $name; -} - -=head2 Actions - -=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 given L C to the mailbox, -setting its L and -L. -L is set to L if the message -does not already have a C. - -=cut - -sub add_message { - my $self = shift; - my $message = shift; - - # Basic message setup first - $message->mailbox($self); - $message->sequence( @{ $self->messages } + 1 ); - push @{ $self->messages }, $message; - - # Some messages may supply their own uids - if ( $message->uid ) { - $self->uidnext( $message->uid + 1 ) - if $message->uid >= $self->uidnext; - } else { - $message->uid( $self->uidnext ); - $self->uidnext( $self->uidnext + 1 ); - } - $self->uids->{ $message->uid } = $message; - - # 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) ) { - next unless $c->temporary_messages; - - push @{ $c->temporary_messages }, $message; - $c->temporary_sequence_map->{$message} - = scalar @{ $c->temporary_messages }; - } - return $message; -} - -=head3 add_child [...] - -Creates a mailbox under this mailbox, of the same class as this -mailbox is. Any arguments are passed to L. 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 } ); - return unless $node; - push @{ $self->children }, $node; - return $node; -} - -=head3 create [...] - -Identical to L. Should return false if the create is -denied or fails. - -=cut - -sub create { - my $self = shift; - return $self->add_child(@_); -} - -=head3 reparent MAILBOX [NAME] - -Reparents this mailbox to be a child of the given -L C, with the given C. -Should return 0 if the reparenting is denied or fails. - -=cut - -sub reparent { - my $self = shift; - my $parent = shift; - - $self->parent->children( - [ grep { $_ ne $self } @{ $self->parent->children } ] ); - push @{ $parent->children }, $self; - $self->parent($parent); - $self->name(shift) if @_; - $self->full_path( purge => 1 ); - 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 } ] ); - - 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 ( - # Except if we find our own connection; if this is - # *not* part of a poll, we asked for it, so no need to - # set up temporary messages. - ( Net::IMAP::Server->connection and - $c eq Net::IMAP::Server->connection - and not $c->in_poll - ) - 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->_unsent_expunge }, @ids; - } - - return 1; -} - -=head3 append MESSAGE - -Appends, and returns, the given C, 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 separator - -Returns the path separator. Note that only the path separator of the -root mailbox matters. Defaults to a forward slash. - -If the function returns is undef, the server supports only flat -mailboxes (i.e. no child mailboxes are allowed). - -=cut - -sub separator { - return "/"; -} - -=head3 full_path [purge => 1] - -Returns the full path to this mailbox. This value is cached -aggressively on a per-connection basis; passing C flushes this -cache, if the path name has changed. - -=cut - -sub full_path { - my $self = shift; - my %args = @_; - my $cache - = Net::IMAP::Server->connection - ? ( Net::IMAP::Server->connection->{path_cache} ||= {} ) - : {}; - - if ($args{purge}) { - my @uncache = ($self); - while (@uncache) { - my $o = shift @uncache; - delete $cache->{$o.""}; - push @uncache, @{ $o->children }; - } - } - - return $cache->{$self.""} - if defined $cache->{$self.""}; - $cache->{$self.""} = - !$self->parent ? "" - : !$self->parent->parent ? $self->name - : $self->parent->full_path . $self->separator . $self->name; - return $cache->{$self.""}; -} - -=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 to check. - -=cut - -sub can_set_flag { - my $self = shift; - my $flag = shift; - - 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->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 }; -} - -=head3 first_unseen - -Returns the sequence number of the first message which does not have -the C<\Seen> flag set. Returns 0 if all messages have been marked as -C<\Seen>. - -=cut - -sub first_unseen { - my $self = shift; - for ( @{ $self->messages } ) { - next if $_->has_flag('\Seen'); - return Net::IMAP::Server->connection - ? Net::IMAP::Server->connection->sequence($_) - : $_->sequence; - } - return 0; -} - -=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 }; -} - -=head3 permanentflags - -Returns the flags which will be stored permanently for this mailbox; -defaults to the same set as L returns. - -=cut - -sub permanentflags { - my $self = shift; - return $self->flags; -} - - -=head3 status TYPES - -Called when the clients requests a status update (via -L). C should be the types -of information requested, chosen from this list: - -=over - -=item MESSAGES - -The number of messages in the mailbox (via L) - -=item RECENT - -The number of messages marked as C<\Recent> (via L) - -=item UNSEEN - -The number of messages not marked as C<\Seen> (via L) - -=item UIDVALIDITY - -The C of the mailbox. - -=item UIDNEXT - -The C of the mailbox. - -=back - -=cut - -sub status { - my $self = shift; - my (@keys) = @_; - $self->poll; - my %items; - for my $i ( @keys ) { - if ( $i eq "MESSAGES" ) { - $items{$i} = $self->exists; - } elsif ( $i eq "RECENT" ) { - $items{$i} = $self->recent; - } elsif ( $i eq "UNSEEN" ) { - $items{$i} = $self->unseen; - } elsif ( $i eq "UIDVALIDITY" ) { - my $uidvalidity = $self->uidvalidity; - $items{$i} = $uidvalidity if defined $uidvalidity; - } elsif ( $i eq "UIDNEXT" ) { - my $uidnext = $self->uidnext; - $items{$i} = $uidnext if defined $uidnext; - } - } - return %items; -} - -=head3 read_only - -Returns true if this mailbox is read-only. By default, the value of -this depends on if the mailbox was selected using C or -C