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 valid_mailbox NAME Returns false and calls L</bad_command> if the given C<NAME> is a valid name for a mailbox. This only checks that is passes UTF-7 encoding checks, and that it contains no 8-bit characters. If the name is valid, simply returns 1. =cut sub valid_mailbox { my $self = shift; my ($name) = @_; # Check for high-bit characters return $self->bad_command("Mailbox name contains 8-bit data") if $name =~ /[\x80-\xFF]/; # 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', $name ) ); }; return $self->bad_command("Invalid UTF-7 encoding") unless defined $roundtrip and $roundtrip eq $name; return 1; } =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;