—
—
—
—
—
—
—
—
—
—
—
—
—
—
—
—
—

              
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)
);
HideShow 17 lines of Pod
=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;
}
HideShow 23 lines of Pod
=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;
}
HideShow 11 lines of Pod
=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" );
}
HideShow 9 lines of Pod
=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;
}
HideShow 7 lines of Pod
=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 ] );
}
HideShow 12 lines of Pod
=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(@_) };
}
HideShow 47 lines of Pod
=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 "";
}
HideShow 6 lines of Pod
=head2 untagged_response STRING
Sends an untagged response to the client.
=cut
sub untagged_response {
    my $self = shift;
    $self->connection->untagged_response(@_);
}
HideShow 6 lines of Pod
=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, @_;
}
HideShow 8 lines of Pod
=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}
HideShow 8 lines of Pod
=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;
}
HideShow 8 lines of Pod
=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;
}
HideShow 6 lines of Pod
=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 );
}
HideShow 8 lines of Pod
=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;
}
HideShow 7 lines of Pod
=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;
}
HideShow 6 lines of Pod
=head2 log SEVERITY, MESSAGE
Defers to L<Net::IMAP::Server::Connection/log>.
=cut
sub log {
    my $self = shift;
    $self->connection->log(@_);
}
HideShow 6 lines of Pod
=head2 out MESSAGE
Identical to L<Net::IMAP::Server::Connection/out>.
=cut
sub out {
    my $self = shift;
    $self->connection->out(@_);
}
1;