package Net::IMAP::Simple;
use strict;
use vars qw($VERSION);
$VERSION = '0.93';
use IO::Socket;
use IO::File;
#############################################################################
#
#
#
#############################################################################
sub new {
my ( $class, $server, %options ) = @_;
my ( $self );
if ( ref( $class ) ) {
$class = ref( $class );
}
$self = { %options };
$self->{count} = 0;
$self->{sock} = new IO::Socket::INET( "$server:143" )
or return;
$self->{sock}->getline();
bless $self, $class;
return $self;
}
#############################################################################
#
#
#
#############################################################################
sub _nextid {
my ( $self ) = @_;
return $self->{count}++;
}
#############################################################################
#
#
#
#############################################################################
sub _escape {
my ( $str ) = @_;
$str =~ s/\\/\\\\/g;
$str =~ s/\"/\\\"/g;
$str = "\"$str\"";
return $str;
}
#############################################################################
#
#
#
#############################################################################
sub _unescape {
my ( $str ) = @_;
$str =~ s/^"//g;
$str =~ s/"$//g;
$str =~ s/\\\"/\"/g;
$str =~ s/\\\\/\\/g;
return $str;
}
#############################################################################
#
#
#
#############################################################################
sub login {
my ( $self, $user, $pass ) = @_;
my ( $sh, $id, $resp );
$sh = $self->{sock};
$id = $self->_nextid();
print $sh "$id LOGIN $user $pass\r\n";
$resp = $sh->getline();
if ( $resp =~ /^$id\s+OK/i ) {
return $self->select( 'INBOX' );
}
return;
}
#############################################################################
#
#
#
#############################################################################
sub select {
my ( $self, $mbox ) = @_;
my ( $sh, $id, $resp, $nmsg );
$sh = $self->{sock};
$id = $self->_nextid();
$mbox = _escape( $mbox );
print $sh "$id SELECT $mbox\r\n";
while ( $resp = $sh->getline() ) {
if ( $resp =~ /^\*\s+(\d+)\s+EXISTS/i ) {
$nmsg = $1;
} elsif ( $resp =~ /^$id\s+(OK|NO|BAD)/i ) {
last;
}
}
if ( defined $nmsg && $resp =~ /$id\s+OK/i ) {
$self->{last} = $nmsg;
return $nmsg;
}
return;
}
#############################################################################
#
#
#
#############################################################################
sub top {
my ( $self, $msgn ) = @_;
my ( $sh, $id, $resp, $lines );
$sh = $self->{sock};
$id = $self->_nextid();
print $sh "$id FETCH $msgn rfc822.header\r\n";
while ( $resp = $sh->getline() ) {
if ( $resp =~ /^\*/ ) {
next;
}
if ( $resp =~ /^$id\s+(OK|NO|BAD)/i ) {
last;
}
push @$lines, $resp;
}
if ( $resp =~ /$id\s+OK/i ) {
pop @$lines;
return $lines;
}
return;
}
#############################################################################
#
#
#
#############################################################################
sub seen {
my ( $self, $msgn ) = @_;
my ( $sh, $id, $resp, $lines );
$sh = $self->{sock};
$id = $self->_nextid();
print $sh "$id FETCH $msgn (FLAGS)\r\n";
while ( $resp = $sh->getline() ) {
if ( $resp =~ /^$id\s+(OK|NO|BAD)/i ) {
last;
}
$lines .= $resp;
}
if ( $resp =~ /$id\s+OK/i ) {
return $lines =~ /\\Seen/i;
}
return;
}
#############################################################################
#
#
#
#############################################################################
sub list {
my ( $self, $msgn ) = @_;
my ( $sh, $id, $resp, $hash );
$sh = $self->{sock};
$id = $self->_nextid();
if ( defined $msgn ) {
print $sh "$id FETCH $msgn RFC822.SIZE\r\n";
} else {
print $sh "$id FETCH 1:$self->{last} RFC822.SIZE\r\n";
}
while ( $resp = $sh->getline() ) {
if ( $resp =~ /^\*\s+(\d+).*RFC822.SIZE\s+(\d+)/i ) {
$hash->{$1} = $2;
next;
}
if ( $resp =~ /^$id\s+(OK|NO|BAD)/i ) {
last;
}
}
if ( $resp =~ /$id\s+OK/i ) {
if ( defined $msgn ) {
return $hash->{$msgn};
} else {
return $hash;
}
}
return;
}
#############################################################################
#
#
#
#############################################################################
sub get {
my ( $self, $msgn ) = @_;
my ( $sh, $id, $resp, $lines );
$sh = $self->{sock};
$id = $self->_nextid();
print $sh "$id FETCH $msgn rfc822\r\n";
while ( $resp = $sh->getline() ) {
if ( $resp =~ /^\*/ ) {
next;
}
if ( $resp =~ /^$id\s+(OK|NO|BAD)/i ) {
last;
}
push @$lines, $resp;
}
if ( $resp =~ /$id\s+OK/i ) {
pop @$lines;
return $lines;
}
return;
}
#############################################################################
#
#
#
#############################################################################
sub getfh {
my ( $self, $msgn ) = @_;
my ( $sh, $id, $resp, $buffer, $fh );
$fh = IO::File->new_tmpfile()
or return;
$sh = $self->{sock};
$id = $self->_nextid();
print $sh "$id FETCH $msgn rfc822\r\n";
while ( $resp = $sh->getline() ) {
if ( $resp =~ /^\*/ ) {
next;
}
if ( $resp =~ /^$id\s+(OK|NO|BAD)/i ) {
last;
}
print $fh $buffer if ( defined $buffer );
$buffer = $resp;
}
if ( $resp =~ /$id\s+OK/i ) {
seek $fh, 0, 0;
return $fh;
}
$fh->close();
return;
}
#############################################################################
#
#
#
#############################################################################
sub quit {
my ( $self ) = @_;
my ( $sh, $id );
$sh = $self->{sock};
$id = $self->_nextid();
print $sh "$id EXPUNGE\r\n";
$id = $self->_nextid();
print $sh "$id LOGOUT\r\n";
<$sh>;
close $sh;
return 1;
}
#############################################################################
#
#
#
#############################################################################
sub last {
my ( $self ) = @_;
return $self->{last};
}
#############################################################################
#
#
#
#############################################################################
sub delete {
my ( $self, $msgn ) = @_;
my ( $sh, $id, $resp );
$sh = $self->{sock};
$id = $self->_nextid();
print $sh "$id STORE $msgn +FLAGS (\\Deleted)\r\n";
while ( ( $resp = $sh->getline() ) && $resp !~ /^$id\s+(OK|NO|BAD)/i ) {
next;
}
if ( $resp =~ /^$id\s+OK/i ) {
return 1;
}
return;
}
#############################################################################
#
#
#
#############################################################################
sub mailboxes {
my ( $self ) = @_;
my ( $sh, $id, $resp, @list );
$sh = $self->{sock};
$id = $self->_nextid();
print $sh "$id LIST \"\" *\r\n";
while ( $resp = $sh->getline() ) {
if ( $resp =~ /^\*\s+LIST.*\s+\{\d+\}\s*$/i ) {
$resp = $sh->getline();
chomp( $resp );
$resp =~ s/\r$//;
push @list, _escape( $resp );
} elsif ( $resp =~ /^\*\s+LIST.*\s+(\".*?\")\s*$/i ) {
push @list, $1;
} elsif ( $resp =~ /^\*\s+LIST.*\s+(\S+)\s*$/i ) {
push @list, $1;
} elsif ( $resp =~ /^$id\s+(OK|NO|BAD)/i ) {
last;
}
}
if ( $resp =~ /^$id\s+OK/i ) {
map { $_ = _unescape( $_ ) } @list;
# map { s/\\\"/\"/g } @list;
# map { s/^\"// } @list;
# map { s/\"$// } @list;
return @list;
}
return;
}
#############################################################################
#
#
#
#############################################################################
sub create_mailbox {
my ( $self, $mbox_name ) = @_;
my ( $sh, $id, $resp, @list );
$sh = $self->{sock};
$id = $self->_nextid();
$mbox_name = _escape( $mbox_name );
print $sh "$id CREATE $mbox_name\r\n";
$resp = $sh->getline();
if ( $resp =~ /^$id\s+OK/i ) {
return 1;
}
return;
}
#############################################################################
#
#
#
#############################################################################
sub delete_mailbox {
my ( $self, $mbox_name ) = @_;
my ( $sh, $id, $resp, @list );
$sh = $self->{sock};
$id = $self->_nextid();
$mbox_name = _escape( $mbox_name );
print $sh "$id DELETE $mbox_name\r\n";
$resp = $sh->getline();
if ( $resp =~ /^$id\s+OK/i ) {
return 1;
}
return;
}
#############################################################################
#
#
#
#############################################################################
sub rename_mailbox {
my ( $self, $mbox_name, $new_name ) = @_;
my ( $sh, $id, $resp, @list );
$sh = $self->{sock};
$id = $self->_nextid();
$mbox_name = _escape( $mbox_name );
$new_name = _escape( $new_name );
print $sh "$id RENAME $mbox_name $new_name\r\n";
$resp = $sh->getline();
if ( $resp =~ /^$id\s+OK/i ) {
return 1;
}
return;
}
#############################################################################
#
#
#
#############################################################################
sub copy {
my ( $self, $msgn, $mbox_name ) = @_;
my ( $sh, $id, $resp, @list );
$sh = $self->{sock};
$id = $self->_nextid();
$mbox_name = _escape( $mbox_name );
print $sh "$id COPY $msgn $mbox_name\r\n";
$resp = $sh->getline();
if ( $resp =~ /^$id\s+OK/i ) {
return 1;
}
return;
}
1;
__END__
=head1 NAME
Net::IMAP::Simple - Perl extension for simple IMAP account handling, mostly
compatible with Net::POP3.
=head1 SYNOPSIS
use Net::IMAP::Simple;
# open a connection to the IMAP server
$server = new Net::IMAP::Simple( 'someserver' );
# login
$server->login( 'someuser', 'somepassword' );
# select the desired folder
$number_of_messages = $server->select( 'somefolder' );
# go through all the messages in the selected folder
foreach $msg ( 1..$number_of_messages ) {
if ( $server->seen( $msg ) {
print "This message has been read before...\n"
}
# get the message, returned as a reference to an array of lines
$lines = $server->get( $msg );
# print it
print @$lines;
# get the message, returned as a temporary file handle
$fh = $server->getfh( $msg );
print <$fh>;
close $fh;
}
# the list of all folders
@folders = $server->mailboxes();
# create a folder
$server->create_mailbox( 'newfolder' );
# rename a folder
$server->rename_mailbox( 'newfolder', 'renamedfolder' );
# delete a folder
$server->delete_mailbox( 'renamedfolder' );
# copy a message to another folder
$server->copy( $self, $msg, 'renamedfolder' );
# close the connection
$server->quit();
=head1 DESCRIPTION
This module is a simple way to access IMAP accounts. The API is mostly
equivalent to the Net::POP3 one, with some aditional methods for mailbox
handling.
=head1 BUGS
I don't know how the module reacts to nested mailboxes.
This module was only tested under the following servers:
=over 4
=item *
Netscape IMAP4rev1 Service 3.6
=item *
MS Exchange 5.5.1960.6 IMAPrev1 (Thanks to Edward Chao)
=item *
Cyrus IMAP Server v1.5.19 (Thanks to Edward Chao)
=back
Expect some problems with servers from other vendors (then again, if
all of them are implementing the IMAP protocol, it should work - but
we all know how it goes).
=head1 AUTHOR
Joao Fonseca, joao_g_fonseca@yahoo.com
=head1 SEE ALSO
Net::IMAP(1), Net::POP3(1).
=head1 COPYRIGHT
Copyright (c) 1999 Joao Fonseca. All rights reserved.
This program is free software; you can redistribute it
and/or modify it under the same terms as Perl itself.
=cut