X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FNet%2FPOP3.pm;h=8381c81815e7cd0af764a6d2172dc5d09eb02f0f;hb=89b2b9f7f6c8f99f7999c5b3fe437be2abac4340;hp=7cd44ef179943804fbf9ad9cb9df3a4e59f4c533;hpb=dea4d7dfbb03f4a0014d53b245f3d8b5b801961c;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/Net/POP3.pm b/lib/Net/POP3.pm index 7cd44ef..8381c81 100644 --- a/lib/Net/POP3.pm +++ b/lib/Net/POP3.pm @@ -1,6 +1,6 @@ # Net::POP3.pm # -# Copyright (c) 1995-1997 Graham Barr . All rights reserved. +# Copyright (c) 1995-2004 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. @@ -13,50 +13,63 @@ use Net::Cmd; use Carp; use Net::Config; -$VERSION = "2.24"; # $Id: //depot/libnet/Net/POP3.pm#24 $ +$VERSION = "2.29"; @ISA = qw(Net::Cmd IO::Socket::INET); -sub new -{ - my $self = shift; - my $type = ref($self) || $self; - my $host = shift if @_ % 2; - my %arg = @_; - my $hosts = defined $host ? [ $host ] : $NetConfig{pop3_hosts}; - my $obj; - my @localport = exists $arg{ResvPort} ? ( LocalPort => $arg{ResvPort} ): (); - - my $h; - foreach $h (@{$hosts}) - { - $obj = $type->SUPER::new(PeerAddr => ($host = $h), - PeerPort => $arg{Port} || 'pop3(110)', - Proto => 'tcp', - @localport, - Timeout => defined $arg{Timeout} - ? $arg{Timeout} - : 120 - ) and last; + +sub new { + my $self = shift; + my $type = ref($self) || $self; + 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}) : (); + + my $h; + foreach $h (@{$hosts}) { + $obj = $type->SUPER::new( + PeerAddr => ($host = $h), + PeerPort => $arg{Port} || 'pop3(110)', + Proto => 'tcp', + @localport, + Timeout => defined $arg{Timeout} + ? $arg{Timeout} + : 120 + ) + and last; } - return undef - unless defined $obj; + return undef + unless defined $obj; - ${*$obj}{'net_pop3_host'} = $host; + ${*$obj}{'net_pop3_host'} = $host; - $obj->autoflush(1); - $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef); + $obj->autoflush(1); + $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef); - unless ($obj->response() == CMD_OK) - { - $obj->close(); - return undef; + unless ($obj->response() == CMD_OK) { + $obj->close(); + return undef; } - ${*$obj}{'net_pop3_banner'} = $obj->message; + ${*$obj}{'net_pop3_banner'} = $obj->message; - $obj; + $obj; +} + + +sub host { + my $me = shift; + ${*$me}{'net_pop3_host'}; } ## @@ -64,268 +77,272 @@ sub new ## now do we :-) ## + sub debug_text { $_[2] =~ /^(pass|rpop)/i ? "$1 ....\n" : $_[2]; } -sub login -{ - @_ >= 1 && @_ <= 3 or croak 'usage: $pop3->login( USER, PASS )'; - my($me,$user,$pass) = @_; - if (@_ <= 2) { - ($user, $pass) = $me->_lookup_credentials($user); - } +sub login { + @_ >= 1 && @_ <= 3 or croak 'usage: $pop3->login( USER, PASS )'; + my ($me, $user, $pass) = @_; - $me->user($user) and - $me->pass($pass); + if (@_ <= 2) { + ($user, $pass) = $me->_lookup_credentials($user); + } + + $me->user($user) + and $me->pass($pass); } -sub apop -{ - @_ >= 1 && @_ <= 3 or croak 'usage: $pop3->apop( USER, PASS )'; - my($me,$user,$pass) = @_; - my $banner; - 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; - } +sub apop { + @_ >= 1 && @_ <= 3 or croak 'usage: $pop3->apop( USER, PASS )'; + my ($me, $user, $pass) = @_; + my $banner; + my $md; - return undef - unless ( $banner = (${*$me}{'net_pop3_banner'} =~ /(<.*>)/)[0] ); + 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; + } - if (@_ <= 2) { - ($user, $pass) = $me->_lookup_credentials($user); - } + return undef + unless ($banner = (${*$me}{'net_pop3_banner'} =~ /(<.*>)/)[0]); + + if (@_ <= 2) { + ($user, $pass) = $me->_lookup_credentials($user); + } - $md->add($banner,$pass); + $md->add($banner, $pass); - return undef - unless($me->_APOP($user,$md->hexdigest)); + return undef + unless ($me->_APOP($user, $md->hexdigest)); - $me->_get_mailbox_count(); + $me->_get_mailbox_count(); } -sub user -{ - @_ == 2 or croak 'usage: $pop3->user( USER )'; - $_[0]->_USER($_[1]) ? 1 : undef; + +sub user { + @_ == 2 or croak 'usage: $pop3->user( USER )'; + $_[0]->_USER($_[1]) ? 1 : undef; } -sub pass -{ - @_ == 2 or croak 'usage: $pop3->pass( PASS )'; - my($me,$pass) = @_; +sub pass { + @_ == 2 or croak 'usage: $pop3->pass( PASS )'; + + my ($me, $pass) = @_; - return undef - unless($me->_PASS($pass)); + return undef + unless ($me->_PASS($pass)); - $me->_get_mailbox_count(); + $me->_get_mailbox_count(); } -sub reset -{ - @_ == 1 or croak 'usage: $obj->reset()'; - my $me = shift; +sub reset { + @_ == 1 or croak 'usage: $obj->reset()'; + + my $me = shift; - return 0 - unless($me->_RSET); + return 0 + unless ($me->_RSET); - if(defined ${*$me}{'net_pop3_mail'}) - { - local $_; - foreach (@{${*$me}{'net_pop3_mail'}}) - { - delete $_->{'net_pop3_deleted'}; + if (defined ${*$me}{'net_pop3_mail'}) { + local $_; + foreach (@{${*$me}{'net_pop3_mail'}}) { + delete $_->{'net_pop3_deleted'}; } } } -sub last -{ - @_ == 1 or croak 'usage: $obj->last()'; - return undef +sub last { + @_ == 1 or croak 'usage: $obj->last()'; + + return undef unless $_[0]->_LAST && $_[0]->message =~ /(\d+)/; - return $1; + return $1; } -sub top -{ - @_ == 2 || @_ == 3 or croak 'usage: $pop3->top( MSGNUM [, NUMLINES ])'; - my $me = shift; - return undef +sub top { + @_ == 2 || @_ == 3 or croak 'usage: $pop3->top( MSGNUM [, NUMLINES ])'; + my $me = shift; + + return undef unless $me->_TOP($_[0], $_[1] || 0); - $me->read_until_dot; + $me->read_until_dot; } -sub popstat -{ - @_ == 1 or croak 'usage: $pop3->popstat()'; - my $me = shift; - return () +sub popstat { + @_ == 1 or croak 'usage: $pop3->popstat()'; + my $me = shift; + + return () unless $me->_STAT && $me->message =~ /(\d+)\D+(\d+)/; - ($1 || 0, $2 || 0); + ($1 || 0, $2 || 0); } -sub list -{ - @_ == 1 || @_ == 2 or croak 'usage: $pop3->list( [ MSGNUM ] )'; - my $me = shift; - return undef +sub list { + @_ == 1 || @_ == 2 or croak 'usage: $pop3->list( [ MSGNUM ] )'; + my $me = shift; + + return undef unless $me->_LIST(@_); - if(@_) - { - $me->message =~ /\d+\D+(\d+)/; - return $1 || undef; + if (@_) { + $me->message =~ /\d+\D+(\d+)/; + return $1 || undef; } - my $info = $me->read_until_dot - or return undef; + my $info = $me->read_until_dot + or return undef; - my %hash = map { (/(\d+)\D+(\d+)/) } @$info; + my %hash = map { (/(\d+)\D+(\d+)/) } @$info; - return \%hash; + return \%hash; } -sub get -{ - @_ == 2 or @_ == 3 or croak 'usage: $pop3->get( MSGNUM [, FH ])'; - my $me = shift; - return undef +sub get { + @_ == 2 or @_ == 3 or croak 'usage: $pop3->get( MSGNUM [, FH ])'; + my $me = shift; + + return undef unless $me->_RETR(shift); - $me->read_until_dot(@_); + $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 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]); +sub delete { + @_ == 2 or croak 'usage: $pop3->delete( MSGNUM )'; + my $me = shift; + return 0 unless $me->_DELE(@_); + ${*$me}{'net_pop3_deleted'} = 1; } -sub uidl -{ - @_ == 1 || @_ == 2 or croak 'usage: $pop3->uidl( [ MSGNUM ] )'; - my $me = shift; - my $uidl; - $me->_UIDL(@_) or - return undef; - if(@_) - { - $uidl = ($me->message =~ /\d+\s+([\041-\176]+)/)[0]; +sub uidl { + @_ == 1 || @_ == 2 or croak 'usage: $pop3->uidl( [ MSGNUM ] )'; + my $me = shift; + my $uidl; + + $me->_UIDL(@_) + or return undef; + if (@_) { + $uidl = ($me->message =~ /\d+\s+([\041-\176]+)/)[0]; } - else - { - my $ref = $me->read_until_dot - or return undef; - my $ln; - $uidl = {}; - foreach $ln (@$ref) { - my($msg,$uid) = $ln =~ /^\s*(\d+)\s+([\041-\176]+)/; - $uidl->{$msg} = $uid; - } + else { + my $ref = $me->read_until_dot + or return undef; + my $ln; + $uidl = {}; + foreach $ln (@$ref) { + my ($msg, $uid) = $ln =~ /^\s*(\d+)\s+([\041-\176]+)/; + $uidl->{$msg} = $uid; + } } - return $uidl; + return $uidl; } -sub ping -{ - @_ == 2 or croak 'usage: $pop3->ping( USER )'; - my $me = shift; - return () unless $me->_PING(@_) && $me->message =~ /(\d+)\D+(\d+)/; +sub ping { + @_ == 2 or croak 'usage: $pop3->ping( USER )'; + my $me = shift; - ($1 || 0, $2 || 0); + return () unless $me->_PING(@_) && $me->message =~ /(\d+)\D+(\d+)/; + + ($1 || 0, $2 || 0); } -sub _lookup_credentials -{ + +sub _lookup_credentials { my ($me, $user) = @_; require Net::Netrc; - $user ||= eval { local $SIG{__DIE__}; (getpwuid($>))[0] } || - $ENV{NAME} || $ENV{USER} || $ENV{LOGNAME}; + $user ||= eval { local $SIG{__DIE__}; (getpwuid($>))[0] } + || $ENV{NAME} + || $ENV{USER} + || $ENV{LOGNAME}; - my $m = Net::Netrc->lookup(${*$me}{'net_pop3_host'},$user); + my $m = Net::Netrc->lookup(${*$me}{'net_pop3_host'}, $user); $m ||= Net::Netrc->lookup(${*$me}{'net_pop3_host'}); - my $pass = $m ? $m->password || "" - : ""; + my $pass = $m + ? $m->password || "" + : ""; ($user, $pass); } -sub _get_mailbox_count -{ + +sub _get_mailbox_count { my ($me) = @_; - my $ret = ${*$me}{'net_pop3_count'} = ($me->message =~ /(\d+)\s+message/io) - ? $1 : ($me->popstat)[0]; + 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 _RETR { shift->command('RETR',$_[0])->response() == CMD_OK } -sub _DELE { shift->command('DELE',$_[0])->response() == CMD_OK } +sub _LIST { shift->command('LIST', @_)->response() == CMD_OK } +sub _RETR { shift->command('RETR', $_[0])->response() == CMD_OK } +sub _DELE { shift->command('DELE', $_[0])->response() == CMD_OK } sub _NOOP { shift->command('NOOP')->response() == CMD_OK } sub _RSET { shift->command('RSET')->response() == CMD_OK } sub _QUIT { shift->command('QUIT')->response() == CMD_OK } sub _TOP { shift->command('TOP', @_)->response() == CMD_OK } -sub _UIDL { shift->command('UIDL',@_)->response() == CMD_OK } -sub _USER { shift->command('USER',$_[0])->response() == CMD_OK } -sub _PASS { shift->command('PASS',$_[0])->response() == CMD_OK } -sub _APOP { shift->command('APOP',@_)->response() == CMD_OK } -sub _PING { shift->command('PING',$_[0])->response() == CMD_OK } +sub _UIDL { shift->command('UIDL', @_)->response() == CMD_OK } +sub _USER { shift->command('USER', $_[0])->response() == CMD_OK } +sub _PASS { shift->command('PASS', $_[0])->response() == CMD_OK } +sub _APOP { shift->command('APOP', @_)->response() == CMD_OK } +sub _PING { shift->command('PING', $_[0])->response() == CMD_OK } + -sub _RPOP { shift->command('RPOP',$_[0])->response() == CMD_OK } +sub _RPOP { shift->command('RPOP', $_[0])->response() == CMD_OK } sub _LAST { shift->command('LAST')->response() == CMD_OK } -sub quit -{ - my $me = shift; - $me->_QUIT; - $me->close; +sub _CAPA { shift->command('CAPA')->response() == CMD_OK } + + +sub quit { + my $me = shift; + + $me->_QUIT; + $me->close; } -sub DESTROY -{ - my $me = shift; - if(defined fileno($me)) - { - $me->reset; - $me->quit; +sub DESTROY { + my $me = shift; + + if (defined fileno($me) and ${*$me}{'net_pop3_deleted'}) { + $me->reset; + $me->quit; } } @@ -333,28 +350,178 @@ sub DESTROY ## 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"; - $cmd->debug_print(0,$str) - if ($cmd->debug); +sub response { + my $cmd = shift; + my $str = $cmd->getline() or return undef; + my $code = "500"; + + $cmd->debug_print(0, $str) + if ($cmd->debug); + + if ($str =~ s/^\+OK\s*//io) { + $code = "200"; + } + 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); - if($str =~ s/^\+OK\s*//io) - { - $code = "200" + # 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 - { - $str =~ s/^-ERR\s*//io; + 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}; + } } - ${*$cmd}{'net_cmd_resp'} = [ $str ]; - ${*$cmd}{'net_cmd_code'} = $code; + return ${*$this}{'net_pop3e_capabilities'} = \%capabilities; +} + - substr($code,0,1); +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; +} + + +sub banner { + my $this = shift; + + return ${*$this}{'net_pop3_banner'}; } 1; @@ -398,17 +565,23 @@ on the object. =over 4 -=item new ( [ HOST, ] [ OPTIONS ] ) +=item new ( [ HOST ] [, OPTIONS ] 0 This is the constructor for a new Net::POP3 object. C 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 is not given, then the C specified in C -will be used. +C is optional. If C is not given then it may instead be +passed as the C option described below. If neither is given then +the C specified in C will be used. C are passed in a hash like fashion, using key and value pairs. Possible options are: +B - POP3 host to connect to. It may be a single scalar, as defined for +the C option in L, or a reference to +an array with hosts to try in turn. The L method will return the value +which was used to connect to the host. + B - If given then the socket for the C object will be bound to the local port given using C when the socket is created. @@ -429,6 +602,10 @@ empty list. =over 4 +=item auth ( USERNAME, PASSWORD ) + +Attempt SASL authentication. + =item user ( USER ) Send the USER command. @@ -458,6 +635,23 @@ Similar to L, 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. +=item banner () + +Return the sever's connection banner + +=item capa () + +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 ] ) Get the header and the first C of the body for the message @@ -514,7 +708,7 @@ when the server connection closed. =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 () @@ -541,12 +735,8 @@ Graham Barr =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
- -I<$Id: //depot/libnet/Net/POP3.pm#24 $> - =cut