Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

not willing to maintain this shit anymore

  • Loading branch information...
commit 782f44e956c5328f6cec716fc55a616122abec17 1 parent 60e68e2
@jettero authored
Showing with 0 additions and 4,927 deletions.
  1. +0 −41 MANIFEST
  2. +0 −569 inc/Net/IMAP/Server.pm
  3. +0 −399 inc/Net/IMAP/Server/Command.pm
  4. +0 −53 inc/Net/IMAP/Server/Command/Append.pm
  5. +0 −70 inc/Net/IMAP/Server/Command/Authenticate.pm
  6. +0 −23 inc/Net/IMAP/Server/Command/Capability.pm
  7. +0 −27 inc/Net/IMAP/Server/Command/Check.pm
  8. +0 −30 inc/Net/IMAP/Server/Command/Close.pm
  9. +0 −48 inc/Net/IMAP/Server/Command/Copy.pm
  10. +0 −54 inc/Net/IMAP/Server/Command/Create.pm
  11. +0 −34 inc/Net/IMAP/Server/Command/Delete.pm
  12. +0 −11 inc/Net/IMAP/Server/Command/Examine.pm
  13. +0 −31 inc/Net/IMAP/Server/Command/Expunge.pm
  14. +0 −45 inc/Net/IMAP/Server/Command/Fetch.pm
  15. +0 −31 inc/Net/IMAP/Server/Command/Id.pm
  16. +0 −78 inc/Net/IMAP/Server/Command/List.pm
  17. +0 −39 inc/Net/IMAP/Server/Command/Login.pm
  18. +0 −27 inc/Net/IMAP/Server/Command/Logout.pm
  19. +0 −27 inc/Net/IMAP/Server/Command/Lsub.pm
  20. +0 −33 inc/Net/IMAP/Server/Command/Namespace.pm
  21. +0 −23 inc/Net/IMAP/Server/Command/Noop.pm
  22. +0 −53 inc/Net/IMAP/Server/Command/Rename.pm
  23. +0 −206 inc/Net/IMAP/Server/Command/Search.pm
  24. +0 −61 inc/Net/IMAP/Server/Command/Select.pm
  25. +0 −31 inc/Net/IMAP/Server/Command/Starttls.pm
  26. +0 −39 inc/Net/IMAP/Server/Command/Status.pm
  27. +0 −51 inc/Net/IMAP/Server/Command/Store.pm
  28. +0 −32 inc/Net/IMAP/Server/Command/Subscribe.pm
  29. +0 −137 inc/Net/IMAP/Server/Command/Uid.pm
  30. +0 −32 inc/Net/IMAP/Server/Command/Unsubscribe.pm
  31. +0 −638 inc/Net/IMAP/Server/Connection.pm
  32. +0 −114 inc/Net/IMAP/Server/DefaultAuth.pm
  33. +0 −161 inc/Net/IMAP/Server/DefaultModel.pm
  34. +0 −33 inc/Net/IMAP/Server/Error.pm
  35. +0 −688 inc/Net/IMAP/Server/Mailbox.pm
  36. +0 −646 inc/Net/IMAP/Server/Message.pm
  37. +0 −9 t/Auth.pm
  38. +0 −18 t/CanFlag.pm
  39. +0 −24 t/Connection.pm
  40. +0 −35 t/Model.pm
  41. +0 −15 t/Shutdown.pm
  42. +0 −54 t/test_runner.pm
  43. +0 −157 t/test_server.pm
View
41 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
View
569 inc/Net/IMAP/Server.pm
@@ -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<Net::Server::Coro>.
-
-=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<RFC 3501>
-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<certs/>
-directory under the current working directory, containing files
-F<server-cert.pem> and C<server-key.pem>. 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</server_cert> and
-L</server_key> arguments to L</new>.
-
-=head1 INTERFACE
-
-The primary method of using this module is to supply your own model
-and auth classes, which inherit from
-L<Net::IMAP::Server::DefaultModel> and
-L<Net::IMAP::Server::DefaultAuth>. This allows you to back your
-messages from arbitrary data sources, or provide your own
-authorization backend. 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<die> if it
-cannot find the appropriate certificate files. Valid arguments to
-C<new> 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<Net::IMAP::Server::DefaultAuth>.
-
-=item model_class
-
-The name of the class which implements the model backend. This must
-be a subclass of L<Net::IMAP::Server::DefaultModel>.
-
-=item connection_class
-
-On rare occasions, you may wish to subclass the connection class; this
-class must be a subclass of L<Net::IMAP::Server::Connection>.
-
-=item 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<must> 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<Net::Server> arguments -- see its
-documentation for details on their use.
-
-=over
-
-=item L<Net::Server/log_level>
-
-=item L<Net::Server/log_file>
-
-=item L<Net::Server/syslog_logsock>
-
-=item L<Net::Server/syslog_ident>
-
-=item L<Net::Server/syslog_logopt>
-
-=item L<Net::Server/syslog_facility>
-
-=item L<Net::Server/pid_file>
-
-=item L<Net::Server/chroot>
-
-=item L<Net::Server/user>
-
-=item L<Net::Server/group>
-
-=item L<Net::Server/reverse_lookups>
-
-=item L<Net::Server/allow>
-
-=item L<Net::Server/deny>
-
-=item L<Net::Server/cidr_allow>
-
-=item L<Net::Server/cidr_deny>
-
-=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</connection>, whatever parts
-of the IMAP internals they need.
-
-Any arguments are passed through to L<Net::Server/run>.
-
-=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<Net::Server> 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<Net::IMAP::Server::Connection> 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<Net::IMAP::Server::Connection> 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<Net::IMAP::Server::DefaultAuth/user> is the same as the given
-L<USER> (which defaults to the current connection's user)
-
-=cut
-
-sub concurrent_user_connections {
- my $class = shift;
- my $self = ref $class ? $class : $Net::IMAP::Server::Server;
- my $user = shift || $self->connection->auth->user;
-
- return () unless $user;
- return
- grep { $_->is_auth and $_->auth->user eq $user }
- @{ $self->connections };
-}
-
-=head2 capability
-
-Returns the C<CAPABILITY> string for the server. This string my be
-modified by the connection before being sent to the client (see
-L<Net::IMAP::Server::Connection/capability>).
-
-=cut
-
-sub capability {
- my $self = shift;
- return "IMAP4rev1 STARTTLS 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<NAME> to the server's list of known commands.
-C<PACKAGE> should be the name of a class which inherits from
-L<Net::IMAP::Server::Command>.
-
-=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<Net::Server/log>, which outputs to syslog, a
-logfile, or STDERR, depending how it was configured. L<Net::Server>'s
-default is to print to STDERR. If you have custom logging needs,
-override this method, or L<Net::Server/write_to_log_hook>.
-
-=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<connections> (1). It also has a
-sense of the I<current> C<connection> (2), based on the active L<Coro>
-thread.
-
-=item Connection
-
-Connections hold a reference to their C<server> (1). If the
-connection has authenticated, they hold a reference to the C<auth>
-object (2), and to their C<model> (3). If a mailbox is C<selected>
-(4), they hold a pointer to that, as well. Infrequently, the
-connection will need to temporarily store references to the set of
-C<temporary_messages> (5) which have been expunged in other
-connections, but we have been unable to notify this connection of.
-
-=item Command
-
-Commands store their C<server> (1) and C<connection> (2).
-
-=item Model
-
-Models store a reference to the C<root> (1) of their mailbox tree, as
-well as to the C<auth> (2) which gives them access to such.
-
-=item Mailbox
-
-Mailboxes store a list of C<children> mailboxes (1), and C<messages>
-(2) contained within them, which are stored in sequence order. They
-also contain a hash of C<uids> (3) for fast UID retrieval of
-messages. If they are not the root mailbox, they also store a
-reference to their C<parent> mailbox (4).
-
-=item Message
-
-Messages store the C<mailbox> (1) in which they are contained.
-
-=back
-
-=head1 DEPENDENCIES
-
-L<Coro>, L<Net::Server::Coro>
-
-=head1 BUGS AND LIMITATIONS
-
-No bugs have been reported.
-
-Please report any bugs or feature requests to
-C<bug-net-imap-server@rt.cpan.org>, or through the web interface at
-L<http://rt.cpan.org>.
-
-A low-traffic mailing list exists for discussion on how to (ab)use
-this module, at
-L<http://lists.bestpractical.com/cgi-bin/mailman/listinfo/net-imap-server>.
-
-=head1 AUTHOR
-
-Alex Vandiver C<< <alexmv@bestpractical.com> >>
-
-=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<perlartistic>.
-
-=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.
View
399 inc/Net/IMAP/Server/Command.pm
@@ -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</validate> and L</run> methods.
-
-=head1 METHODS
-
-=head2 new
-
-Called by the connection to create a new command.
-
-=cut
-
-sub new {
- my $class = shift;
- my $self = $class->SUPER::new(@_);
- $self->_parsed_options( [] );
- $self->_literals( [] );
- return $self;
-}
-
-=head2 server
-
-Gets or sets the L<Net::IMAP::Server> associated with this command.
-
-=cut
-
-=head2 connection
-
-Gets or sets the L<Net::IMAP::Server::Connection> associated with this
-command.
-
-=cut
-
-=head2 validate
-
-Called before the command is run. If it returns a false value, the
-command is not run; it will probably want to inspect
-L</parsed_options>. If C<validate> returns a false value, it is
-responsible for calling L</no_command> or L</bad_command> to notify
-the client of the failure. Handily, these return a false value.
-
-=cut
-
-sub validate {
- return 1;
-}
-
-=head2 run
-
-Does the guts of the command. The return value is ignored; the
-command is in charge of eventually sending one of L</ok_command>,
-L</bad_command>, or L</no_command> to the client.
-
-The default implementation simply always response with
-L</bad_command>.
-
-=cut
-
-sub run {
- my $self = shift;
-
- $self->bad_command( "command '" . 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<Net::IMAP::Server::Connection/pending>
-callback to continue the parsing, and returns true.
-
-=cut
-
-sub has_literal {
- my $self = shift;
- unless ( $self->options_str =~ /\{(\d+)(\+)?\}[\r\n]*$/ ) {
- $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<parsed_options>.
-
-=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<DATA>.
-
-=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<undef> is output as C<NIL>.
-
-=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<type>
-key is taken to be how the C<value> key should be output. Options for
-C<type> are C<string> or C<literal>.
-
-=cut
-
-sub data_out {
- my $self = shift;
- my $data = shift;
- 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<Net::IMAP::Server::Connection/send_untagged>, but only
-if the command has a true L</poll_after>.
-
-=cut
-
-sub send_untagged {
- my $self = shift;
- $self->connection->send_untagged(@_) if $self->poll_after;
-}
-
-=head2 ok_command MESSAGE [, RESPONSECODE => STRING, ...]
-
-Sends untagged OK responses for any C<RESPONSECODE> pairs, then
-outputs untagged messages via L</send_untagged>, then sends a tagged
-OK with the given C<MESSAGE>.
-
-=cut
-
-sub ok_command {
- my $self = shift;
- my $message = shift;
- 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<OK COMPLETED> tagged response to the client.
-
-=cut
-
-sub ok_completed {
- my $self = shift;
- my %extra_responses = (@_);
- $self->ok_command( uc( $self->command ) . " COMPLETED",
- %extra_responses );
-}
-
-=head2 no_command MESSAGE [, RESPONSECODE => STRING, ...]
-
-Sends untagged NO responses for any C<RESPONSECODE> pairs, then
-outputs untagged messages via L</send_untagged>, then sends a tagged
-OK with the given C<MESSAGE>.
-
-=cut
-
-sub no_command {
- my $self = shift;
- my $message = shift;
- 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</send_untagged>, then
-sends a tagged C<BAD> response with the given C<REASON>.
-
-=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<Net::IMAP::Server::Connection/log>.
-
-=cut
-
-sub log {
- my $self = shift;
- $self->connection->log(@_);
-}
-
-=head2 out MESSAGE
-
-Identical to L<Net::IMAP::Server::Connection/out>.
-
-=cut
-
-sub out {
- my $self = shift;
- $self->connection->out(@_);
-}
-
-1;
View
53 inc/Net/IMAP/Server/Command/Append.pm
@@ -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;
View
70 inc/Net/IMAP/Server/Command/Authenticate.pm
@@ -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;
View
23 inc/Net/IMAP/Server/Command/Capability.pm
@@ -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;
View
27 inc/Net/IMAP/Server/Command/Check.pm
@@ -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;
View
30 inc/Net/IMAP/Server/Command/Close.pm
@@ -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;
View
48 inc/Net/IMAP/Server/Command/Copy.pm
@@ -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;
View
54 inc/Net/IMAP/Server/Command/Create.pm
@@ -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;
View
34 inc/Net/IMAP/Server/Command/Delete.pm
@@ -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;
View
11 inc/Net/IMAP/Server/Command/Examine.pm
@@ -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;
View
31 inc/Net/IMAP/Server/Command/Expunge.pm
@@ -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;
View
45 inc/Net/IMAP/Server/Command/Fetch.pm
@@ -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;
View
31 inc/Net/IMAP/Server/Command/Id.pm
@@ -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;
View
78 inc/Net/IMAP/Server/Command/List.pm
@@ -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;
View
39 inc/Net/IMAP/Server/Command/Login.pm
@@ -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;
View
27 inc/Net/IMAP/Server/Command/Logout.pm
@@ -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;
View
27 inc/Net/IMAP/Server/Command/Lsub.pm
@@ -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;
View
33 inc/Net/IMAP/Server/Command/Namespace.pm
@@ -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;
View
23 inc/Net/IMAP/Server/Command/Noop.pm
@@ -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;
View
53 inc/Net/IMAP/Server/Command/Rename.pm
@@ -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;
View
206 inc/Net/IMAP/Server/Command/Search.pm
@@ -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;
View
61 inc/Net/IMAP/Server/Command/Select.pm
@@ -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;
View
31 inc/Net/IMAP/Server/Command/Starttls.pm
@@ -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;
View
39 inc/Net/IMAP/Server/Command/Status.pm
@@ -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;
View
51 inc/Net/IMAP/Server/Command/Store.pm
@@ -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;
View
32 inc/Net/IMAP/Server/Command/Subscribe.pm
@@ -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;
View
137 inc/Net/IMAP/Server/Command/Uid.pm
@@ -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;
View
32 inc/Net/IMAP/Server/Command/Unsubscribe.pm
@@ -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;