# Net::POP3.pm
#
-# Copyright (c) 1995-1997 Graham Barr <gbarr@pobox.com>. All rights reserved.
+# Copyright (c) 1995-2004 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
use Carp;
use Net::Config;
-$VERSION = "2.22"; # $Id: //depot/libnet/Net/POP3.pm#19 $
+$VERSION = "2.28_2";
@ISA = qw(Net::Cmd IO::Socket::INET);
{
my $self = shift;
my $type = ref($self) || $self;
- my $host = shift if @_ % 2;
- my %arg = @_;
+ my ($host,%arg);
+ if (@_ % 2) {
+ $host = shift ;
+ %arg = @_;
+ } else {
+ %arg = @_;
+ $host=delete $arg{Host};
+ }
my $hosts = defined $host ? [ $host ] : $NetConfig{pop3_hosts};
my $obj;
my @localport = exists $arg{ResvPort} ? ( LocalPort => $arg{ResvPort} ): ();
$obj;
}
+sub host {
+ my $me = shift;
+ ${*$me}{'net_pop3_host'};
+}
+
##
## We don't want people sending me their passwords when they report problems
## now do we :-)
@_ >= 1 && @_ <= 3 or croak 'usage: $pop3->login( USER, PASS )';
my($me,$user,$pass) = @_;
- if(@_ <= 2)
- {
- require Net::Netrc;
-
- $user ||= eval { (getpwuid($>))[0] } || $ENV{NAME};
-
- my $m = Net::Netrc->lookup(${*$me}{'net_pop3_host'},$user);
-
- $m ||= Net::Netrc->lookup(${*$me}{'net_pop3_host'});
-
- $pass = $m ? $m->password || ""
- : "";
- }
+ if (@_ <= 2) {
+ ($user, $pass) = $me->_lookup_credentials($user);
+ }
$me->user($user) and
$me->pass($pass);
@_ >= 1 && @_ <= 3 or croak 'usage: $pop3->apop( USER, PASS )';
my($me,$user,$pass) = @_;
my $banner;
-
- unless(eval { require MD5 })
- {
- carp "You need to install MD5 to use the APOP command";
+ my $md;
+
+ if (eval { local $SIG{__DIE__}; require Digest::MD5 }) {
+ $md = Digest::MD5->new();
+ } elsif (eval { local $SIG{__DIE__}; require MD5 }) {
+ $md = MD5->new();
+ } else {
+ carp "You need to install Digest::MD5 or MD5 to use the APOP command";
return undef;
- }
+ }
return undef
unless ( $banner = (${*$me}{'net_pop3_banner'} =~ /(<.*>)/)[0] );
- if(@_ <= 2)
- {
- require Net::Netrc;
-
- $user ||= eval { (getpwuid($>))[0] } || $ENV{NAME};
-
- my $m = Net::Netrc->lookup(${*$me}{'net_pop3_host'},$user);
-
- $m ||= Net::Netrc->lookup(${*$me}{'net_pop3_host'});
+ if (@_ <= 2) {
+ ($user, $pass) = $me->_lookup_credentials($user);
+ }
- $pass = $m ? $m->password || ""
- : "";
- }
-
- my $md = MD5->new;
$md->add($banner,$pass);
return undef
unless($me->_APOP($user,$md->hexdigest));
- my $ret = ${*$me}{'net_pop3_count'} = ($me->message =~ /(\d+)\s+message/io)
- ? $1 : ($me->popstat)[0];
-
- $ret ? $ret : "0E0";
+ $me->_get_mailbox_count();
}
sub user
return undef
unless($me->_PASS($pass));
- my $ret = ${*$me}{'net_pop3_count'} = ($me->message =~ /(\d+)\s+message/io)
- ? $1 : ($me->popstat)[0];
-
- $ret ? $ret : "0E0";
+ $me->_get_mailbox_count();
}
sub reset
$me->read_until_dot(@_);
}
+sub getfh
+{
+ @_ == 2 or croak 'usage: $pop3->getfh( MSGNUM )';
+ my $me = shift;
+
+ return unless $me->_RETR(shift);
+ return $me->tied_fh;
+}
+
+
+
sub delete
{
@_ == 2 or croak 'usage: $pop3->delete( MSGNUM )';
- $_[0]->_DELE($_[1]);
+ my $me = shift;
+ return 0 unless $me->_DELE(@_);
+ ${*$me}{'net_pop3_deleted'} = 1;
}
sub uidl
($1 || 0, $2 || 0);
}
+sub _lookup_credentials
+{
+ my ($me, $user) = @_;
+
+ require Net::Netrc;
+
+ $user ||= eval { local $SIG{__DIE__}; (getpwuid($>))[0] } ||
+ $ENV{NAME} || $ENV{USER} || $ENV{LOGNAME};
+
+ my $m = Net::Netrc->lookup(${*$me}{'net_pop3_host'},$user);
+ $m ||= Net::Netrc->lookup(${*$me}{'net_pop3_host'});
+
+ my $pass = $m ? $m->password || ""
+ : "";
+
+ ($user, $pass);
+}
+
+sub _get_mailbox_count
+{
+ my ($me) = @_;
+ my $ret = ${*$me}{'net_pop3_count'} = ($me->message =~ /(\d+)\s+message/io)
+ ? $1 : ($me->popstat)[0];
+
+ $ret ? $ret : "0E0";
+}
+
sub _STAT { shift->command('STAT')->response() == CMD_OK }
sub _LIST { shift->command('LIST',@_)->response() == CMD_OK }
sub _RPOP { shift->command('RPOP',$_[0])->response() == CMD_OK }
sub _LAST { shift->command('LAST')->response() == CMD_OK }
+sub _CAPA { shift->command('CAPA')->response() == CMD_OK }
+
sub quit
{
my $me = shift;
{
my $me = shift;
- if(defined fileno($me))
+ if(defined fileno($me) and ${*$me}{'net_pop3_deleted'})
{
$me->reset;
$me->quit;
## POP3 has weird responses, so we emulate them to look the same :-)
##
-sub response
-{
- my $cmd = shift;
- my $str = $cmd->getline() || return undef;
- my $code = "500";
+sub response {
+ my $cmd = shift;
+ my $str = $cmd->getline() or return undef;
+ my $code = "500";
- $cmd->debug_print(0,$str)
- if ($cmd->debug);
+ $cmd->debug_print(0, $str)
+ if ($cmd->debug);
- if($str =~ s/^\+OK\s+//io)
- {
- $code = "200"
+ if ($str =~ s/^\+OK\s*//io) {
+ $code = "200";
}
- else
- {
- $str =~ s/^-ERR\s+//io;
+ elsif ($str =~ s/^\+\s*//io) {
+ $code = "300";
}
+ else {
+ $str =~ s/^-ERR\s*//io;
+ }
+
+ ${*$cmd}{'net_cmd_resp'} = [$str];
+ ${*$cmd}{'net_cmd_code'} = $code;
+
+ substr($code, 0, 1);
+}
+
+
+sub capa {
+ my $this = shift;
+ my ($capa, %capabilities);
+
+ # Fake a capability here
+ $capabilities{APOP} = '' if ($this->banner() =~ /<.*>/);
+
+ if ($this->_CAPA()) {
+ $capabilities{CAPA} = 1;
+ $capa = $this->read_until_dot();
+ %capabilities = (%capabilities, map { /^\s*(\S+)\s*(.*)/ } @$capa);
+ }
+ else {
+ # Check AUTH for SASL capabilities
+ if ( $this->command('AUTH')->response() == CMD_OK ) {
+ my $mechanism = $this->read_until_dot();
+ $capabilities{SASL} = join " ", map { m/([A-Z0-9_-]+)/ } @{ $mechanism };
+ }
+ }
+
+ return ${*$this}{'net_pop3e_capabilities'} = \%capabilities;
+}
+
+sub capabilities {
+ my $this = shift;
+
+ ${*$this}{'net_pop3e_capabilities'} || $this->capa;
+}
+
+sub auth {
+ my ($self, $username, $password) = @_;
+
+ eval {
+ require MIME::Base64;
+ require Authen::SASL;
+ } or $self->set_status(500,["Need MIME::Base64 and Authen::SASL todo auth"]), return 0;
+
+ my $capa = $self->capa;
+ my $mechanisms = $capa->{SASL} || 'CRAM-MD5';
+
+ my $sasl;
+
+ if (ref($username) and UNIVERSAL::isa($username,'Authen::SASL')) {
+ $sasl = $username;
+ my $user_mech = $sasl->mechanism || '';
+ my @user_mech = split(/\s+/, $user_mech);
+ my %user_mech; @user_mech{@user_mech} = ();
+
+ my @server_mech = split(/\s+/,$mechanisms);
+ my @mech = @user_mech
+ ? grep { exists $user_mech{$_} } @server_mech
+ : @server_mech;
+ unless (@mech) {
+ $self->set_status(500,
+ [ 'Client SASL mechanisms (',
+ join(', ', @user_mech),
+ ') do not match the SASL mechnism the server announces (',
+ join(', ', @server_mech), ')',
+ ]);
+ return 0;
+ }
+
+ $sasl->mechanism(join(" ",@mech));
+ }
+ else {
+ die "auth(username, password)" if not length $username;
+ $sasl = Authen::SASL->new(mechanism=> $mechanisms,
+ callback => { user => $username,
+ pass => $password,
+ authname => $username,
+ });
+ }
+
+ # We should probably allow the user to pass the host, but I don't
+ # currently know and SASL mechanisms that are used by smtp that need it
+ my ( $hostname ) = split /:/ , ${*$self}{'net_pop3_host'};
+ my $client = eval { $sasl->client_new('pop',$hostname,0) };
+
+ unless ($client) {
+ my $mech = $sasl->mechanism;
+ $self->set_status(500, [
+ " Authen::SASL failure: $@",
+ '(please check if your local Authen::SASL installation',
+ "supports mechanism '$mech'"
+ ]);
+ return 0;
+ }
+
+ my ($token) = $client->client_start
+ or do {
+ my $mech = $client->mechanism;
+ $self->set_status(500, [
+ ' Authen::SASL failure: $client->client_start ',
+ "mechanism '$mech' hostname #$hostname#",
+ $client->error
+ ]);
+ return 0;
+ };
+
+ # We dont support sasl mechanisms that encrypt the socket traffic.
+ # todo that we would really need to change the ISA hierarchy
+ # so we dont inherit from IO::Socket, but instead hold it in an attribute
+
+ my @cmd = ("AUTH", $client->mechanism);
+ my $code;
+
+ push @cmd, MIME::Base64::encode_base64($token,'')
+ if defined $token and length $token;
+
+ while (($code = $self->command(@cmd)->response()) == CMD_MORE) {
+
+ my ( $token ) = $client->client_step(
+ MIME::Base64::decode_base64(
+ ($self->message)[0]
+ )
+ ) or do {
+ $self->set_status(500, [
+ ' Authen::SASL failure: $client->client_step ',
+ "mechanism '", $client->mechanism ," hostname #$hostname#, ",
+ $client->error
+ ]);
+ return 0;
+ };
+
+ @cmd = (MIME::Base64::encode_base64(
+ defined $token ? $token : '',
+ ''
+ )
+ );
+ }
+
+ $code == CMD_OK;
+}
- ${*$cmd}{'net_cmd_resp'} = [ $str ];
- ${*$cmd}{'net_cmd_code'} = $code;
+sub banner {
+ my $this = shift;
- substr($code,0,1);
+ return ${*$this}{'net_pop3_banner'};
}
1;
=head1 NAME
-Net::POP3 - Post Office Protocol 3 Client class (RFC1081)
+Net::POP3 - Post Office Protocol 3 Client class (RFC1939)
=head1 SYNOPSIS
$pop = Net::POP3->new('pop3host');
$pop = Net::POP3->new('pop3host', Timeout => 60);
+ if ($pop->login($username, $password) > 0) {
+ my $msgnums = $pop->list; # hashref of msgnum => size
+ foreach my $msgnum (keys %$msgnums) {
+ my $msg = $pop->get($msgnum);
+ print @$msg;
+ $pop->delete($msgnum);
+ }
+ }
+
+ $pop->quit;
+
=head1 DESCRIPTION
This module implements a client interface to the POP3 protocol, enabling
a perl5 application to talk to POP3 servers. This documentation assumes
-that you are familiar with the POP3 protocol described in RFC1081.
+that you are familiar with the POP3 protocol described in RFC1939.
A new Net::POP3 object must be created with the I<new> method. Once
this has been done, all POP3 commands are accessed via method calls
on the object.
-=head1 EXAMPLES
-
- Need some small examples in here :-)
-
=head1 CONSTRUCTOR
=over 4
-=item new ( [ HOST, ] [ OPTIONS ] )
+=item new ( [ HOST ] [, OPTIONS ] 0
This is the constructor for a new Net::POP3 object. C<HOST> is the
-name of the remote host to which a POP3 connection is required.
+name of the remote host to which an POP3 connection is required.
-If C<HOST> is not given, then the C<POP3_Host> specified in C<Net::Config>
-will be used.
+C<HOST> is optional. If C<HOST> is not given then it may instead be
+passed as the C<Host> option described below. If neither is given then
+the C<POP3_Hosts> specified in C<Net::Config> will be used.
C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
Possible options are:
+B<Host> - POP3 host to connect to. It may be a single scalar, as defined for
+the C<PeerAddr> option in L<IO::Socket::INET>, or a reference to
+an array with hosts to try in turn. The L</host> method will return the value
+which was used to connect to the host.
+
B<ResvPort> - If given then the socket for the C<Net::POP3> object
will be bound to the local port given using C<bind> when the socket is
created.
=over 4
+=item auth ( USERNAME, PASSWORD )
+
+Attempt SASL authentication.
+
=item user ( USER )
Send the USER command.
=item login ( [ USER [, PASS ]] )
-Send both the
the USER and PASS commands. If C<PASS> is not given the
+Send both the USER and PASS commands. If C<PASS> is not given the
C<Net::POP3> uses C<Net::Netrc> to lookup the password using the host
and username. If the username is not specified then the current user name
will be used.
If there was an error authenticating the user then I<undef> will be returned.
-=item apop ( USER, PASS )
+=item apop ( [ USER [, PASS ]] )
Authenticate with the server identifying as C<USER> with password C<PASS>.
-Similar ti L<login>, but the password is not sent in clear text.
+Similar to L</login>, but the password is not sent in clear text.
+
+To use this method you must have the Digest::MD5 or the MD5 module installed,
+otherwise this method will return I<undef>.
+
+=item banner ()
+
+Return the sever's connection banner
+
+=item capa ()
-To use this method you must have the MD5 package installed, if you do not
-this method will return I<undef>
+Return a reference to a hash of the capabilities of the server. APOP
+is added as a pseudo capability. Note that I've been unable to
+find a list of the standard capability values, and some appear to
+be multi-word and some are not. We make an attempt at intelligently
+parsing them, but it may not be correct.
+=item capabilities ()
+
+Just like capa, but only uses a cache from the last time we asked
+the server, so as to avoid asking more than once.
=item top ( MSGNUM [, NUMLINES ] )
text read from the server. If C<FH> is given then the lines returned
from the server are printed to the filehandle C<FH>.
+=item getfh ( MSGNUM )
+
+As per get(), but returns a tied filehandle. Reading from this
+filehandle returns the requested message. The filehandle will return
+EOF at the end of the message and should not be reused.
+
=item last ()
Returns the highest C<MSGNUM> of all the messages accessed.
=item reset ()
-Reset the status of the remote POP3 server. This includes reseting the
+Reset the status of the remote POP3 server. This includes resetting the
status of all messages to not be deleted.
=item quit ()
=head1 SEE ALSO
-L<Net::Netrc>
+L<Net::Netrc>,
L<Net::Cmd>
=head1 AUTHOR
=head1 COPYRIGHT
-Copyright (c) 1995-1997 Graham Barr. All rights reserved.
+Copyright (c) 1995-2003 Graham Barr. All rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
-=for html <hr>
-
-I<$Id: //depot/libnet/Net/POP3.pm#19 $>
-
=cut
https://perl5.git.perl.org / perl5.git / blobdiff