PERL IMAP client module
Etienne Goyer
etienne.goyer at linuxquebec.com
Wed Feb 4 12:22:56 EST 2004
On Wed, Feb 04, 2004 at 03:42:47PM +0100, Sebastian Hagedorn wrote:
> > In the same vein, I have an IMAP::MUPDATE module I wrote. The code is
> > not exactly pretty , but it work. I also have a modified Net::Sieve
> > that work with STARTTLS and proxy auth, and a Net::FUD module I wrote
> > from scratch. For those interested, I can share them.
>
> I'd be interested in the last two.
Here they are. Note that the Sieve.pm does not have a copyright notice,
a disclaimer and a license inlined; I included the license.txt that was
shipped with websieve (GPL2). I also recall that I had problem getting
STARTTLS to work; I am not sure if it currently broken or not. The only
SASL mechnism supported is PLAIN, but it does support proxy auth. It
does follow REFERRAL too, if you are in a Murder environnement. Notice
that one big feature missing is documentation; sorry, but you will have
to read the code until I write the POD :)
In a nutshell, the constructor look like :
my $sieve = new IMAP::Sieve(Server => $server,
Proxy => $user, # user to act upon
Login => $mailadmin,
Password => $password);
Net::FUD is much simpler. Just read the POD : "perldoc Net::FUD".
In both case, you just have to drop the .pm somewhere in @INC where it
make sense; under RedHat, I would suggest /usr/lib/perl/site_perl/5.x.x/
under either Net or IMAP.
I welcome any question you may have.
--
Etienne Goyer Linux Québec Technologies Inc.
http://www.LinuxQuebec.com etienne.goyer at linuxquebec.com
-------------- next part --------------
IMAP::Sieve
=====================
This program is free software; you can redistribute it
and/or modify it under the terms of the GNU General Public
License as published by the Free Software Foundation;
either version 2 of the License, or (at your option) any
later version.
This program is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied
warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
PURPOSE. See the GNU General Public License for more
details.
You should have received a copy of the GNU General Public
License along with this program; if not, write to the Free
Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.
A copy of the GNU General Public License can be found in the
file GPL2.txt.
Alain Turbide
-------------- next part --------------
# Net::FUD.pm
# $Id: FUD.pm,v 1.3 2003/07/24 20:38:49 egoyer Exp $
#
# Copyright (c) 2003 Etienne Goyer, Linux Québec Technologies
# <etienne.goyer at linuxquebec.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#
# This package retrieve information on mailbox from a FUD daemon,
# such as bundled by Cyrus imapd.
#
package Net::FUD;
use strict;
use vars qw($VERSION);
use IO::Socket::INET;
$VERSION = "0.01";
sub new {
my $class = shift;
my %self = @_;
unless ($self{'server'}) {
return undef;
}
unless ($self{'port'}) { $self{'port'} = 4201 }
# Connect to server
$self{'socket'} = IO::Socket::INET->new( PeerAddr => $self{'server'},
PeerPort => $self{'port'},
Proto => "udp" );
if ($self{'socket'}->error) {
$self{'error'} = "Error connecting to $self{'server'}:$self{'port'}.";
}
my $ret = \%self;
bless ($ret, $class);
return $ret;
}
sub retr_info {
my $self = shift;
my $user = shift;
my $mbox = shift;
my $fh = $self->{'socket'};
my ($resp, @ret);
unless ($user) { return }
# FIXME : this make the assumption that the mailboxes separator is '.'
unless ($mbox) { $mbox = "user." . $user }
print $fh "$user|$mbox";
sysread($fh, $resp, 511);
if ($resp eq "PERMDENY") {
$self->{'error'} = "Permission denied";
} elsif($resp eq "UNKNOWN") {
$self->{'error'} = "User or mailbox unknown";
} else {
# Parse response
@ret = split /\|/, $resp;
}
return @ret;
}
sub error {
my $self = shift;
return $self->{'error'};
}
# Not sure if these two are necessary
sub close {
my $self = shift;
$self->{'socket'}->close;
}
sub DESTROY {
my $self = shift;
$self->close;
}
1;
__END__
=head1 NAME
Net::FUD - FUD Client class
=head1 SYNOPSIS
use Net::FUD;
$fud = Net::FUD->new( server => "some.host.name", port => 4201);
@info = $fud("johndoe", "user.johndoe.folder")
$err = $fud->error
=head1 DESCRIPTION
C<Net::FUD> is a class implementing a simple client in Perl to the FUD daemon
as shipped with I<Cyrus imapd>.
=head1 CONSTRUCTOR
=over 4
=item new ( server => HOST [, port => PORT ])
Create a new C<Net::FUD> object where HOST is the host to connect to.
Optionnally, you can specify the port PORT (default udp/4201).
=back
=head1 METHODS
=over 4
=item retr_info ( USER [, MAILBOX ])
Retrieve information for mailbox MAILBOX (default to "user.USER" if
unspecified) and user USER. Return an array of five elements on
success, false otherwise. The content of the array is as follow :
=over 5
=item *
$ret[0] : The user for which the information was retrieved
=item *
$ret[1] : The mailbox for which the information was retrieved.
=item *
$ret[2] : Number of messages unseen by the user in this mailbox.
=item *
$ret[3] : Last time I<user> have read the mailbox, in typical Unix timestamp
(second since the epoch) suitable for C<localtime()>.
=item *
$ret[4] : Last time a message was delivered to the I<user>'s mailbox, in Unix
timestamp.
=back
=item close
Close the connection.
=item error
If there was an error then this method will return an error string.
=back
=head1 AUTHOR
Etienne Goyer <etienne.goyer at linuxquebec.com> Linux Québec Technologies
inc.
=head1 COPYRIGHT
Copyright (c) 2003 Linux Québec Technologies. All rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut
-------------- next part --------------
# $Id: Sieve.pm,v 1.4 2003/10/08 15:55:04 egoyer Exp $
package IMAP::Sieve;
use strict;
use Carp;
use IO::Select;
use IO::Socket;
use IO::Socket::INET;
#use Text::ParseWords qw(parse_line);
use Cwd;
use vars qw($VERSION);
$VERSION = '0.4.9b';
sub new {
my $class = shift;
my $self = {};
bless $self, $class;
if ((scalar(@_) % 2) != 0) {
croak "$class called with incorrect number of arguments";
}
while (@_) {
my $key = shift(@_);
my $value = shift(@_);
$self->{$key} = $value;
}
$self->{'CLASS'} = $class;
if ($self->_initialize) {
return $self;
} else {
warn $self->{'Error'};
return undef;
}
}
sub _initialize {
my $self = shift;
my ($len, $userpass, $encode, $resp);
if (!defined($self->{'Server'})) {
croak "$self->{'CLASS'} not initialized properly : Server parameter missing";
}
if (!defined($self->{'Port'})) {
$self->{'Port'} = 2000; # default sieve port;
}
if (!defined($self->{'Login'})) {
croak "$self->{'CLASS'} not initialized properly : Login parameter missing";
}
if (!defined($self->{'Password'})) {
croak "$self->{'CLASS'} not initialized properly : Password parameter missing";
}
if (!defined($self->{'Proxy'})) {
$self->{'Proxy'} = ''; # Proxy;
}
if (!eval {$self->{'Socket'} = IO::Socket::INET->new(PeerAddr => $self->{'Server'},
PeerPort => $self->{'Port'},
Proto => 'tcp',
Reuse => 1); })
{
$self->_error("initialize", "couldn't establish a Sieve connection to",$self->{'Server'});
return 0;
}
my $fh = $self->{'Socket'};
# Throw away initial banner
while ($self->_read !~ m/^OK/i) { };
# Explicitely get capability
$self->_capability;
# FIXME : we may add an option to start or not STARTTLS.
# Here, we unconditionnaly use STARTTLS if available
if ($self->{'STARTTLS'}) {
my $cwd = cwd;
my %ssl_defaults = (
'SSL_use_cert' => 0,
'SSL_verify_mode' => 0x00,
'SSL_key_file' => $cwd."/certs/client-key.pem",
'SSL_cert_file' => $cwd."/certs/client-cert.pem",
'SSL_ca_path' => $cwd."/certs",
'SSL_ca_file' => $cwd."/certs/ca-cert.pem",
'SSL_version' => 'tlsv1'
);
my @ssl_options;
my $ssl_key;
my $key;
foreach $ssl_key (keys(%ssl_defaults)) {
if (!defined($self->{$ssl_key})) {
$self->{$ssl_key} = $ssl_defaults{$ssl_key};
}
}
foreach $ssl_key (keys(%{$self})) {
if ($ssl_key =~ /^SSL_/) {
push @ssl_options, $ssl_key,$self->{$ssl_key};
}
}
my $SSL_try="use IO::Socket::SSL";
eval $SSL_try;
# $IO::Socket::SSL::DEBUG = 4;
if ($self->{'Socket'}->isa('IO::Socket::SSL')) {
$self->_error("initialize", "Socket already use SSL so wont use TLS");
$self->close;
return 0;
}
print $fh "STARTTLS\r\n";
$resp = $self->_read;
if ($resp =~ m/OK/i) {
#IO::Socket::SSL::context_init({@ssl_options});
if (!IO::Socket::SSL::socket_to_SSL($self->{'Socket'}, {@ssl_options})) {
$self->_error("initialize", "Couldn't secure connection with TLS to",$self->{'Server'});
$self->close;
return 0;
}
} elsif ($resp =~ m/^NO/i) {
# Huh ?
warn "Server advertise STARTTLS but refuse negociation";
$self->_error("initialize", "Unknown error negociating TLS",$_);
return 0;
} elsif ($resp =~ m/^BYE/i) {
# FIXME : check for referral
return 0;
} else {
$self->close;
$self->_error("initialize", "Unknown error negociating TLS",$_);
return 0;
}
# This have to be reissued after STARTTLS
$self->_capability;
}
$userpass = "$self->{'Proxy'}\x00".$self->{'Login'}."\x00".$self->{'Password'};
$encode = _encode_base64($userpass);
$len=length($encode);
print $fh "AUTHENTICATE \"PLAIN\" {$len+}\r\n";
print $fh "$encode\r\n";
$resp = $self->_read;
if ($resp =~ m/^NO/i) {
$self->close;
$self->_error("initialize", "Login incorrect while connecting to $self->{'Server'}", $resp);
return 0;
} elsif ($resp =~ m/^OK/i) {
$self->{'Error'}= "No Errors";
return 1;
} elsif ($resp =~ m/^BYE/i) {
if (!$resp =~ m/^BYE \(REFERRAL "(.*?)"/i) {
if ($self->_follow_referral($1)) {
$self->_error("initialize", "Error following referral after authentication : ", $resp);
} else {
$self->{'Error'}="No Errors";
return 1;
}
} else {
$self->_error("initialize", "Unknown error when authenticating",$resp);
}
return 0;
} else {
$self->_error("initialize", "Unknown error when authenticating", $resp);
return 0;
}
# Can't be reached
return;
}
sub _capability {
my $self = shift;
if (!defined($self->{'Socket'})) {
$self->_error("_capability", "no connection open to", $self->{'Server'});
return 0;
}
my $fh = $self->{'Socket'};
# First, we zero out the capability field as they may have changed
# after STARTTLS has been negociated
$self->{'Implementation'} = $self->{'SASL'} = $self->{'SIEVE'} = $self->{'STARTTLS'} = undef;
print $fh "CAPABILITY\r\n";
my $resp;
while ($resp = $self->_read) {
if ($resp =~ m/^OK/i) {
last;
} elsif ($resp =~ m/^BYE/i) {
# FIXME : referral unlikely but possible; should check.
$self->_error("initialize", "Server unavailable.");
return 0;
} elsif ($resp =~ m/^NO/i) {
# Huh ?
$self->_error("initialize", "Server unavailable.");
return 0;
} elsif ($resp =~ m/^"IMPLEMENTATION" "(.*?)"/i) {
$self->{'Implementation'} = $1;
} elsif ($resp =~ m/^"SASL" "(.*?)"/i) {
$self->{'SASL'} = $1;
} elsif ($resp =~ m/^"SIEVE" "(.*?)"/i) {
$self->{'Sieve'} = $1;
} elsif ($resp =~ m/^"STARTTLS"/i) {
$self->{'STARTTLS'} = 1; # not a typo
} else {
# Huh ?
warn "Unknown protocol : $resp";
}
}
return 1;
}
sub _encode_base64 ($;$)
{
# FIXME We could use MIME::Base64, but I guess it make for one less dependance (EG)
my $res = "";
my $eol = $_[1];
$eol = "\n" unless defined $eol;
pos($_[0]) = 0; # ensure start at the beginning
while ($_[0] =~ /(.{1,45})/gs) {
$res .= substr(pack('u', $1), 1);
chop($res);
}
$res =~ tr|` -_|AA-Za-z0-9+/|; # `# help emacs
# fix padding at the end
my $padding = (3 - length($_[0]) % 3) % 3;
$res =~ s/.{$padding}$/'=' x $padding/e if $padding;
# break encoded string into lines of no more than 76 characters each
if (length $eol) {
$res =~ s/(.{1,76})/$1$eol/g;
}
$res;
}
sub _error {
my $self = shift;
my $func = shift;
my @error = @_;
$self->{'Error'} = join(" ",$self->{'CLASS'}, "[", $func, "]:", @error);
}
sub _read {
my $self = shift;
my $buffer ="";
my $char = "";
my $bytes= 1;
while ($bytes == 1) {
$bytes = sysread $self->{'Socket'},$char,1;
if ($bytes == 0) {
if (length ($buffer) != 0) {
return $buffer;
}
else {
return;
}
}
else {
if ($char eq "\n") {
if (length($buffer) == 0) {
# remove any cr or nl leftover
}
else {
return $buffer;
}
}
elsif ($char ne "\r") {
$buffer.=$char;
}
}
}
}
sub _follow_referral {
my $self = shift;
my $new_server = shift;
my $func = shift;
my @args = @_;
unless ($new_server) {
$self->_error("_follow_referral", "No host specified in referral");
return 0;
}
$self->{'Server'} = $new_server;
$self->close;
$self->{'Implementation'} = $self->{'Sieve'} = $self->{'SASL'} = $self->{'STARTTLS'} = undef;
my $init = $self->_initialize;
if ($init and $func) {
return $self->$func(@args);
} else {
return $init;
}
}
sub close {
my $self = shift;
if (!defined($self->{'Socket'})) {
return 0;
}
my $fh =$self->{'Socket'};
print $fh "LOGOUT\r\n";
close($self->{'Socket'});
delete $self->{'Socket'};
}
sub putscript {
my $self = shift;
my $len;
if (scalar(@_) != 2) {
$self->_error("putscript", "incorrect number of arguments");
return 0;
}
my $scriptname = shift;
my $script = shift;
if (!defined($self->{'Socket'})) {
$self->_error("putscript", "no connection open to", $self->{'Server'});
return 0;
}
$len=length($script);
my $fh = $self->{'Socket'};
print $fh "PUTSCRIPT \"$scriptname\" {$len+}\r\n";
print $fh "$script\r\n";
my $resp = $self->_read;
if ($resp =~ /^OK/i) {
$self->{'Error'} = 'No Errors';
return 1;
} elsif ($resp =~ m/^BYE \(REFERRAL "(.*?)"/i) {
return $self->_follow_referral($1, "putscript", $scriptname, $script);
} else {
$self->_error("putscript", "couldn't save script", $scriptname, ":", $resp);
return 0;
}
}
sub deletescript {
my $self = shift;
if (scalar(@_) != 1) {
$self->_error("deletescript", "incorrect number of arguments");
return 0;
}
my $script = shift;
if (!defined($self->{'Socket'})) {
$self->_error("deletescript", "no connection open to", $self->{'Server'});
return 0;
}
my $fh = $self->{'Socket'};
print $fh "DELETESCRIPT \"$script\"\r\n";
my $resp = $self->_read;
if ($resp =~ /^OK/i) {
$self->{'Error'} = 'No Errors';
return 1;
} elsif ($resp =~ m/^BYE \(REFERRAL "(.*?)"/i) {
return $self->_follow_referral($1, "deletescript", $script);
} else {
$self->_error("deletescript", "couldn't delete", $script, ":", $resp);
return 1;
}
}
sub getscript { # returns a string
my $self = shift;
my $allscript;
if (scalar(@_) != 1) {
$self->_error("getscript", "incorrect number of arguments");
return 0;
}
my $script = shift;
if (!defined($self->{'Socket'})) {
$self->_error("getscript", "no connection open to", $self->{'Server'});
return 0;
}
my $fh = $self->{'Socket'};
print $fh "GETSCRIPT \"$script\"\r\n";
my $resp;
while ($resp = $self->_read) {
if ($resp =~ m/^{.*?}/) {
# throw away file size line ... maybe we could make us of it.
next;
} elsif ($resp =~ m/^OK/i) {
return $allscript;
} elsif ($resp =~ m/^NO/i) {
$self->_error("getscript", "couldn't get script", $script, ":", $_);
return 0;
} elsif ($resp =~ m/^BYE "(.*)"/i) {
return $self->_follow_referral($1, "getscript", $script);
} else {
# We assume this is part of the script
$allscript .= $resp . "\n";
}
}
}
sub setactive {
my $self = shift;
if (scalar(@_) != 1) {
$self->_error("setactive", "incorrect number of arguments");
return 0;
}
my $script = shift;
if (!defined($self->{'Socket'})) {
$self->_error("setactive", "no connection open to", $self->{'Server'});
return 0;
}
my $fh = $self->{'Socket'};
print $fh "SETACTIVE \"$script\"\r\n";
my $resp = $self->_read;
if ($resp =~ m/^OK/i) {
$self->{'Error'} = "No Errors";
return 1;
} elsif ($resp =~ m/^NO/i) {
$self->_error("setactive", "couldn't set as active", $script, ":", $resp);
return 0;
} elsif ($resp =~ m/^BYE \(REFERRAL "(.*?)"/i) {
return $self->_follow_referral($1, "setactive", $script);
} else {
$self->_error("setactive", "Unknown error :", $resp);
return 0;
}
}
sub noop {
my $self = shift;
if (!defined($self->{'Socket'})) {
$self->_error("noop", "no connection open to", $self->{'Server'});
return 0;
}
my $fh = $self->{'Socket'};
print $fh "NOOP\r\n";
my $resp = $self->_read;
if ($resp =~ m/^OK/i) {
$self->{'Error'} = 'No Errors';
return 1;
} elsif ($resp =~ m/^BYE \(REFERRAL "(.*?)"/i) {
return $self->_follow_referral($1, "noop");
} else {
$self->_error("noop", "couldn't do noop");
return 0;
}
}
sub _listscripts {
my $self = shift;
my $wantactive = shift;
my (@scripts);
if (!defined($self->{'Socket'})) {
$self->_error("_listscripts", "no connection open to", $self->{'Server'});
return 0;
}
$self->{'Socket'}->print ("LISTSCRIPTS\r\n");
my ($resp, $active);
while ($resp = $self->_read) {
if ($resp =~ m/^OK/i) {
last;
} elsif ($resp =~ m/^BYE \(REFERRAL "(.*?)"/i) {
return $self->_follow_referral($1, "listscripts");
} elsif ($resp =~ m/^NO/i) {
$self->_error("_listscripts", "Unknown error :", $resp);
} elsif ($resp =~ m/"(.*?)" ACTIVE/ and $wantactive) {
$active = $1;
} elsif ($resp =~ m/"(.*?)"/) {
push @scripts, $1;
} else {
$self->_error("_listscripts", "Unknown error :", $resp);
return 0;
}
}
return $wantactive ? $active : @scripts;
}
sub listscripts {
my $self = shift;
return $self->_listscripts;
}
sub listactive {
my $self = shift;
return $self->_listscripts(1);
}
1;
__END__
More information about the Info-cyrus
mailing list