IMAP-Client
view release on metacpan or search on metacpan
lib/IMAP/Client.pm view on Meta::CPAN
# IMAP::Client -low-level advanced IMAP manipulation w/ referral support
#
# Copyright (c) 2005 Brenden Conte <conteb@cpan.org>, All Rights Reserved
#
use strict;
use warnings;
#use diagnostics;
package IMAP::Client;
use IO::Socket::INET;
use IO::Socket::SSL;
use MIME::Base64;
use URI::imap;
use URI::Escape;
use Exporter;
$|=1;
our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
@ISA = qw( Exporter );
$VERSION = "0.13";
@EXPORT = qw ();
@EXPORT_OK = qw();
%EXPORT_TAGS = ();
# Create Class variables
my %Instances;
my @SERVER_RESPONSES = ('exists', 'recent'); # constant value
my $server_response_callback = undef;
my $ID;
=pod
=head1 NAME
IMAP::Client - Advanced manipulation of IMAP services w/ referral support
=head1 SYNOPSIS
use IMAP::Client
my $imap = new IMAP::Client($server);
unless (ref $imap) {
die "Failed to create object: $imap\n";
}
(or)
my $imap = new IMAP::Client();
$imap->connect(PeerAddr => $server,
ConnectMethod => 'SSL STARTTLS PLAIN',
)
or die "Unable to connect to [$server]: ".$imap->error();
$imap->onfail('ERROR');
$imap->errorstyle('STACK');
$imap->debuglevel(1);
$imap->capability_checking(1);
sub showstats ($) {
my $resp = shift;
foreach my $attr (keys %{$resp}) {
print "$attr: $resp->{$attr}\n";
}
}
$imap->register_mailbox_update(\&showstats);
$imap->authenticate($user,$pass)
or die "Unable to authenticate as $user ".$imap->error()."\n";
(or)
lib/IMAP/Client.pm view on Meta::CPAN
next;
}
if (ok_response($resp)) {
if ($i != $#argset) {
print STDERR "WARNING: Only ", $i+1 ," arguments of ", $#argset+1 ," used before successful response in [$command] command\n";
}
# Check for 'server responses' as defined in RFC3501, Section 7.
if ($server_response_callback) {
my %actual_responses;
foreach my $line (@fullresp) {
if (my ($_v, $_t) = $line =~ /(\d+)\s*(\w+)/) { # num-title: # TITLE
foreach my $attr (@SERVER_RESPONSES) { # We only match pre-approved values (FIXME: Is this what we want?)
if (lc($_t) eq lc($attr)) {
$actual_responses{$attr} = $_v;
}
}
}
}
$server_response_callback->(\%actual_responses); # Run the callback with the values
}
# Return the results
return(@fullresp);
} elsif (continue_response($resp)) {
if ($i < $#argset) {
$self->imap_send_tagless($argset[++$i]);
} else {
return($self->throw_error("$command failed: Server wanted more continuations than the ".$#argset." provided"));
}
} elsif (failure_response($resp)) {
return($self->throw_error("$command failed: @fullresp"));
} elsif (untagged_response($resp)) {
# This is just to avoid having untagged responses flagged as 'unrecognised'
} else {
# unrecognized response - put in any times its ok for this to happen in the unless statement.
unless ((lc($command) eq 'fetch') || (lc($command) eq 'uid fetch')) {
return($self->throw_error("INTERNAL ERROR: _IMAP_COMMAND - Unrecognized response from $command: @fullresp"));
}
}
} else {
# We got nothing back.... ? we must have been disconnected
$self->disconnect();
return($self->throw_error("Disconnected\n"));
}
}
# finish reading command, since we're out of arguments
# my @resp = $self->imap_receive();
# (ok_response(@resp)) ?
# return(@resp) :
# return($self->throw_error("$command failed: @resp"));
}
##### connect
=pod
=item B<connect(%args)>
Connect to the supplied IMAP server. Inerits all the options of IO::Socket::SSL (and thusly, IO::Socket::INET), and adds the following custom options:
=over 4
=item ConnectMethod
=over 2
Sets the priority of the login methods via a space seperated priority-ordered list. Valid methods are 'SSL', 'STARTTLS', and 'PLAIN'. The default is to try loggin in via SSL, then connecting to the standard IMAP port and negotiating STARTTLS. 'PLA...
The 'STARTTLS' method uses the starttls() command to negotiate the insecure connection to a secure status - it is functionally equivlant to using the 'PLAIN' method and subsequently calling starttls() within the program.
=back
=item IMAPSPort
=over 2
Set the IMAPS port to use when connecting via the SSL method (default 993).
=back
=item IMAPPort
=over 2
Set the IMAP port to use when connecting via the STARTTLS or PLAIN methods (default 143).
=back
=back
The error logs are cleared during a connection attempt, since (re)connecting essentially is a new session, and any previous errors cannot have any relation the current operation. Also, the act of finding the proper method of connecting can generate ...
Returns 1 on success, and undef on failure, setting error().
=cut
sub connect($%) {
my ($self, %args) = @_;
$self->throw_error("No arguments supplied to connect") unless (%args);
my @methods = ($args{ConnectMethod}) ? split(' ',$args{ConnectMethod}) : qw(SSL STARTTLS);
my $connected;
my $errorstr;
my $server;
foreach my $method (@methods) {
my @resp;
if ($method eq "SSL") {
$args{PeerPort} = $args{IMAPSPort} || 993;
unless ($server = new IO::Socket::SSL(%args)) {
$errorstr .= "SSL Attempt: ". IO::Socket::SSL::errstr() ."\n";
next;
}
} elsif ($method eq 'STARTTLS') {
$args{PeerPort} = $args{IMAPPort} || 143;
unless ($server = new IO::Socket::INET(%args)) {
$errorstr .= "STARTTLS Attempt: Unable to connect: $@\n";
next;
}
} elsif ($method eq 'PLAIN') {
$args{PeerPort} = $args{IMAPPort} || 143;
unless ($server = new IO::Socket::INET(%args)) {
$errorstr .= "PLAIN Attempt: Unable to connect: $@\n";
next;
}
}
# Execute a command to verify we're connected - some servers will accept a connection
# but immediately dump the connection if something isn't supported (i.e. Exchange and
# connecting to Non-ssl when SSL is required by the server)
$self->{'server'} = $server;
@resp = $self->imap_receive_tagless(); # collect welcome
if ($resp[0] && untagged_ok_response(@resp) && ok_response($self->noop())) {
# Post-processing
if ($method eq 'STARTTLS') {
if ($self->starttls(%args)) {
$connected = 'ok';
last;
} else {
$errorstr .= "STARTTLS Attempt: ".$self->error()."\n";
next;
}
} else {
$connected = 'ok';
}
} else {
$errorstr .= "$method attempt: Connection dropped upon connect\n";
}
}
if (!$connected) {
chop($errorstr); # clip the tailing newline: we print errors without them
return ($self->throw_error($errorstr));
} else {
$self->{'server'} = $server;
$self->error; # clear error logs
}
return(1);
}
=pod
=item B<disconnect()>
Disconnect from the server. This command can safely be used on an already-disconnected server.
=cut
sub disconnect($) {
my ($self) = @_;
lib/IMAP/Client.pm view on Meta::CPAN
return($self->{capability});
}
my @resp = $self->_imap_command("CAPABILITY", undef);
# Cache the results if ok:
if ($resp[0]) {
$self->{capability} = @resp;
my %abilities;
foreach my $line (@resp) { # find the untagged capability line
if (my ($capability) = $line =~ /^\*\s+CAPABILITY (.*)$/) {
foreach my $caps (split(/ /,$capability)) {
$abilities{$caps} = 1;
}
last;
}
}
$self->{capabilities} = \%abilities;
}
return(@resp);
}
=pod
=item B<noop()>
Issue a "No Operation" command - i.e. do nothing. Also used for idling and checking for state changes in the select()ed mailbox
=cut
sub noop() {
my ($self) = @_;
return($self->_imap_command("NOOP", undef));
}
=pod
=item B<logout()>
Log the current user out and return This function will not work for multi-stage commands, such as those that issue a '+ go ahead' to indicate the continuation to send data.the connection to the unauthorized state.
=cut
sub logout() {
my ($self) = @_;
$self->{user} = '';
$self->{auth} = '';
# FIXME: untagged response BYE required by rfc - check for it?
return($self->_imap_command("LOGOUT", undef));
}
# not authenticated state
=pod
=item B<starttls(%args)>
Issue a STARTTLS negotiation to secure the data connection. This function will call capability() twice - once before issuing the starttls() command to verify that the atom STARTTLS is listed as a capability(), and once after the sucessful negotiatio...
STARTTLS is checked in capability() regardless of the value of capability_checking().
Any call arguments in %args are passed onto the underlying IO::Socket::SSL->start_SSL() function.
This function returns 1 on success, since there is no output to return on success. Failures are treated normally.
=cut
sub starttls ($%){
my ($self, %args) = @_;
unless ($self->check_capability('STARTTLS')) {
return($self->throw_error("STARTTLS not found in CAPABILITY"));
}
my @recv = $self->_imap_command("STARTTLS",undef);
$self->dprint(0x01, "<TLS negotiations>\n"); # compensation for lack of tapping into dump
$args{SSL_version} ||= 'TLSv1';
if (IO::Socket::SSL->start_SSL($self->{'server'}, %args)) {
# per RFC 3501 - 6.2.1, we must re-establish the CAPABILITY of the server after STARTTLS
$self->{capability} = '';
@recv = $self->capability();
} else {
return($self->throw_error("STARTTLS Attempt: ".IO::Socket::SSL::errstr()))
}
return(@recv);
}
=pod
=item B<authenticate($login, $password)>
=item B<authenticate($login, $password, $authorize_as)>
=item B<authenticate2($login, $password)>
=item B<authenticate2($login, $password, $authorize_as)>
Login in using the AUTHENTICATE mechanism. This mechanism supports authorization as someone other than the logged in user, if said user has permission to do so.
authenticate() uses a one-line login sequence, while authenticate2() uses a multi-line login sequence. Both are provided for compatiblity reasons.
OBSOLETE WARNING: In the future, this split-line behavior will be controlled by an object function, and authenticate() will be the only function.
=cut
sub authenticate($$$) { # One-line version of authentication
my ($self,$login,$passwd,$autheduser) = @_;
$self->error; # clear error logs
$self->{user} = $login;
$self->{auth} = $autheduser || $login;
$autheduser='' unless (defined $autheduser);
my $encoded = encode_base64("$autheduser\000$login\000$passwd");
return($self->_imap_command("AUTHENTICATE","PLAIN $encoded"));
}
sub authenticate2($$$) { # Multi-line version of authentication
my ($self,$login,$passwd,$autheduser) = @_;
$self->error; # clear error logs
$self->{user} = $login;
$self->{auth} = $autheduser || $login;
$autheduser='' unless (defined $autheduser);
my $encoded = encode_base64("$autheduser\000$login\000$passwd");
return($self->_imap_command("AUTHENTICATE","PLAIN","$encoded"));
}
=pod
=item B<login($username,$password)>
Login using the basic LOGIN mechanism. Passwords are sent in the clear, and there is no third-party authorization support.
=cut
sub login ($$$) {
my ($self,$username,$password) = @_;
$self->{user} = $self->{auth} = $username;
return($self->_imap_command("LOGIN","$username $password"));
}
# authenticated state
=pod
=item B<select($mailbox)>
Open a mailbox in read-write mode so that messages in the mailbox can be accessed. This function returns a hash of the valid tagless responses. According to RFC-3501, these responses include:
lib/IMAP/Client.pm view on Meta::CPAN
4.2 MESSAGE/RFC822
4.2.HEADER ([RFC-2822] header of the message)
4.2.TEXT ([RFC-2822] text body of the message) MULTIPART/MIXED
4.2.1 TEXT/PLAIN
4.2.2 MULTIPART/ALTERNATIVE
4.2.2.1 TEXT/PLAIN
4.2.2.2 TEXT/RICHTEXT
=back
This example is rather complicated, but it gets the point across that this is no small feat. From the top, you can see that the HEADER and the TEXT are seperate pieces for the main message that was delivered, and thus can be retrieved as such. 1, 2...
Now, lets look at a concrete example. Lets say that we received a plain-text email with a forwarded email as an attachment. This would mean that the message contains 2 parts, and, for the sake of argument, we know this ahead of time. The command t...
=over 4
my %fetch = $imap->fetch($sequence, {'body' => '2.header'});
=back
For this example, however, we're going to retrieve the entire message, but still seek out the forwarded message's header
=over 4
my %fetch = $imap->fetch($sequence, {});
=back
where $imap is a connected IMAP::Client instance, and $sequence has the message ID we are looking for.
Now, we need to retrieve the data that the IMAP server do dutifully sent to us, and this is where we get grease on our hands and learn exactly how to traverse a fetch response.
The first level of a fetch response is always the message ID of the message, and is the only level that is *not* a reference. This allows the fetch command to retrieve multiple message within a single command (i.e. using the sequence of '1:*' will r...
Lets say that $sequence was the message '1234'. In order to reach the base of the message we are looking to retrieve the data from, we now need to access $fetch{1234}. Everything below here is information about our message.
Next, we will need to navigate to the area of the tree that will contain the data. The data we are looking for will *always* be in the same place, no matter if we retrieved the entire message, half the message, or just that one single peice of data,...
At this level ($fetch{1234}), we can access anything about the main message. We are looking at the message from the outside, what you would normally see in your email client when you first opened a message. We can look at things like the date of th...
In this case, we're not interested in the main message, however. We want to retrieve the header of the forwarded message, so we need to go into the BODY of the message. To get there, we're now at $fetch{1234}->{BODY}. IMAP::Client uses the {BODY} ...
Now that we're in the body, we can look at things like the content type of this particular piece of the email. Again, we're not interested in whats here. What we want is the second part of this body, the attachment part. The main body of the email...
Now at $fetch{1234}->{BODY}->{2}, we're in the section of the message we are interested in. Here we can find out information about the part we're in. This part is essentially identical to the first {BODY} part, only representing a subset of the mes...
Now that we're here, we want the header for this part, which gives us $fetch{1234}->{BODY}->{2}->{HEADER}. We're not done yet, however, as there is still information about the HEADER available, like the SIZE. If we want the acutal HEADER body of th...
In the last example, we assumed that we already knew the struture of the email. In real life, this is almost never the case. If you need to know what the structure of a message looks like so you can extract a small piece of it, you can use the BODY...
=head1 AUTHOR/COPYRIGHT
Copyright 2005-2006, Brenden Conte <conteb at cpan dot org> All rights reserved.
This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
=head1 SEE ALSO
perl, IO::Socket, IO::Socket::SSL, MIME::Base64, URI, URI::imap, URI::Escape
=cut
1;
__END__
( run in 3.335 seconds using v1.01-cache-2.11-cpan-39bf76dae61 )