[p5sagit/p5-mst-13.2.git] / lib / Net / POP3.pm

# Net::POP3.pm
#
# 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.

package Net::POP3;

use strict;
use IO::Socket;
use vars qw(@ISA $VERSION $debug);
use Net::Cmd;
use Carp;
use Net::Config;

$VERSION = "2.28_2";

@ISA = qw(Net::Cmd IO::Socket::INET);

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;

 ${*$obj}{'net_pop3_host'} = $host;

 $obj->autoflush(1);
 $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef);

 unless ($obj->response() == CMD_OK)
  {
   $obj->close();
   return undef;
  }

 ${*$obj}{'net_pop3_banner'} = $obj->message;

 $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 :-)
##

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);
 }

 $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;
 }

 return undef
   unless ( $banner = (${*$me}{'net_pop3_banner'} =~ /(<.*>)/)[0] );

 if (@_ <= 2) {
   ($user, $pass) = $me->_lookup_credentials($user);
 }

 $md->add($banner,$pass);

 return undef
    unless($me->_APOP($user,$md->hexdigest));

 $me->_get_mailbox_count();
}

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) = @_;

 return undef
   unless($me->_PASS($pass));

 $me->_get_mailbox_count();
}

sub reset
{
 @_ == 1 or croak 'usage: $obj->reset()';

 my $me = shift;

 return 0 
   unless($me->_RSET);

 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
    unless $_[0]->_LAST && $_[0]->message =~ /(\d+)/;

 return $1;
}

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;
}

sub popstat
{
 @_ == 1 or croak 'usage: $pop3->popstat()';
 my $me = shift;

 return ()
    unless $me->_STAT && $me->message =~ /(\d+)\D+(\d+)/;

 ($1 || 0, $2 || 0);
}

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;
  }

 my $info = $me->read_until_dot
	or return undef;

 my %hash = map { (/(\d+)\D+(\d+)/) } @$info;

 return \%hash;
}

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(@_);
}

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 )';
 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];
  }
 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;
}

sub ping
{
 @_ == 2 or croak 'usage: $pop3->ping( USER )';
 my $me = shift;

 return () unless $me->_PING(@_) && $me->message =~ /(\d+)\D+(\d+)/;

 ($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 _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 _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;

 $me->_QUIT;
 $me->close;
}

sub DESTROY
{
 my $me = shift;

 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() 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);

    # 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;
}

sub banner {
    my $this = shift;

    return ${*$this}{'net_pop3_banner'};
}

1;

__END__

=head1 NAME

Net::POP3 - Post Office Protocol 3 Client class (RFC1939)

=head1 SYNOPSIS

    use Net::POP3;

    # Constructors
    $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 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 CONSTRUCTOR

=over 4

=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 an POP3 connection is required.

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.

B<Timeout> - Maximum time, in seconds, to wait for a response from the
POP3 server (default: 120)

B<Debug> - Enable debugging information

=back

=head1 METHODS

Unless otherwise stated all methods return either a I<true> or I<false>
value, with I<true> meaning that the operation was a success. When a method
states that it returns a value, failure will be returned as I<undef> or an
empty list.

=over 4

=item auth ( USERNAME, PASSWORD )

Attempt SASL authentication.

=item user ( USER )

Send the USER command.

=item pass ( PASS )

Send the PASS command. Returns the number of messages in the mailbox.

=item login ( [ USER [, PASS ]] )

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.

Returns the number of messages in the mailbox. However if there are no
messages on the server the string C<"0E0"> will be returned. This is
will give a true value in a boolean context, but zero in a numeric context.

If there was an error authenticating the user then I<undef> will be returned.

=item apop ( [ USER [, PASS ]] )

Authenticate with the server identifying as C<USER> with password C<PASS>.
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 ()

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<NUMLINES> of the body for the message
C<MSGNUM>. Returns a reference to an array which contains the lines of text
read from the server.

=item list ( [ MSGNUM ] )

If called with an argument the C<list> returns the size of the message
in octets.

If called without arguments a reference to a hash is returned. The
keys will be the C<MSGNUM>'s of all undeleted messages and the values will
be their size in octets.

=item get ( MSGNUM [, FH ] )

Get the message C<MSGNUM> from the remote mailbox. If C<FH> is not given
then get returns a reference to an array which contains the lines of
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 popstat ()

Returns a list of two elements. These are the number of undeleted
elements and the size of the mbox in octets.

=item ping ( USER )

Returns a list of two elements. These are the number of new messages
and the total number of messages for C<USER>.

=item uidl ( [ MSGNUM ] )

Returns a unique identifier for C<MSGNUM> if given. If C<MSGNUM> is not
given C<uidl> returns a reference to a hash where the keys are the
message numbers and the values are the unique identifiers.

=item delete ( MSGNUM )

Mark message C<MSGNUM> to be deleted from the remote mailbox. All messages
that are marked to be deleted will be removed from the remote mailbox
when the server connection closed.

=item reset ()

Reset the status of the remote POP3 server. This includes resetting the
status of all messages to not be deleted.

=item quit ()

Quit and close the connection to the remote POP3 server. Any messages marked
as deleted will be deleted from the remote mailbox.

=back

=head1 NOTES

If a C<Net::POP3> object goes out of scope before C<quit> method is called
then the C<reset> method will called before the connection is closed. This
means that any messages marked to be deleted will not be.

=head1 SEE ALSO

L<Net::Netrc>,
L<Net::Cmd>

=head1 AUTHOR

Graham Barr <gbarr@pobox.com>

=head1 COPYRIGHT

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.

=cut
Commit	Line	Data
406c51ee	1	# Net::POP3.pm
406c51ee	2	#
f92f3fcb	3	# Copyright (c) 1995-2004 Graham Barr <gbarr@pobox.com>. All rights reserved.
406c51ee	4	# This program is free software; you can redistribute it and/or
	5	# modify it under the same terms as Perl itself.
	6
	7	package Net::POP3;
	8
	9	use strict;
	10	use IO::Socket;
	11	use vars qw(@ISA $VERSION $debug);
	12	use Net::Cmd;
	13	use Carp;
	14	use Net::Config;
	15
7cf5cf7c	16	$VERSION = "2.28_2";
406c51ee	17
	18	@ISA = qw(Net::Cmd IO::Socket::INET);
	19
	20	sub new
	21	{
	22	my $self = shift;
	23	my $type = ref($self) \|\| $self;
f92f3fcb	24	my ($host,%arg);
	25	if (@_ % 2) {
	26	$host = shift ;
	27	%arg = @_;
	28	} else {
	29	%arg = @_;
	30	$host=delete $arg{Host};
	31	}
406c51ee	32	my $hosts = defined $host ? [ $host ] : $NetConfig{pop3_hosts};
	33	my $obj;
	34	my @localport = exists $arg{ResvPort} ? ( LocalPort => $arg{ResvPort} ): ();
	35
	36	my $h;
	37	foreach $h (@{$hosts})
	38	{
	39	$obj = $type->SUPER::new(PeerAddr => ($host = $h),
	40	PeerPort => $arg{Port} \|\| 'pop3(110)',
	41	Proto => 'tcp',
	42	@localport,
	43	Timeout => defined $arg{Timeout}
	44	? $arg{Timeout}
	45	: 120
	46	) and last;
	47	}
	48
	49	return undef
	50	unless defined $obj;
	51
	52	${*$obj}{'net_pop3_host'} = $host;
	53
	54	$obj->autoflush(1);
	55	$obj->debug(exists $arg{Debug} ? $arg{Debug} : undef);
	56
	57	unless ($obj->response() == CMD_OK)
	58	{
	59	$obj->close();
	60	return undef;
	61	}
	62
	63	${*$obj}{'net_pop3_banner'} = $obj->message;
	64
	65	$obj;
	66	}
	67
f92f3fcb	68	sub host {
	69	my $me = shift;
	70	${*$me}{'net_pop3_host'};
	71	}
	72
406c51ee	73	##
	74	## We don't want people sending me their passwords when they report problems
	75	## now do we :-)
	76	##
	77
	78	sub debug_text { $_[2] =~ /^(pass\|rpop)/i ? "$1 ....\n" : $_[2]; }
	79
	80	sub login
	81	{
	82	@_ >= 1 && @_ <= 3 or croak 'usage: $pop3->login( USER, PASS )';
	83	my($me,$user,$pass) = @_;
	84
12df23ee	85	if (@_ <= 2) {
	86	($user, $pass) = $me->_lookup_credentials($user);
	87	}
406c51ee	88
	89	$me->user($user) and
	90	$me->pass($pass);
	91	}
	92
	93	sub apop
	94	{
	95	@_ >= 1 && @_ <= 3 or croak 'usage: $pop3->apop( USER, PASS )';
	96	my($me,$user,$pass) = @_;
	97	my $banner;
12df23ee	98	my $md;
	99
	100	if (eval { local $SIG{__DIE__}; require Digest::MD5 }) {
	101	$md = Digest::MD5->new();
	102	} elsif (eval { local $SIG{__DIE__}; require MD5 }) {
	103	$md = MD5->new();
	104	} else {
	105	carp "You need to install Digest::MD5 or MD5 to use the APOP command";
406c51ee	106	return undef;
12df23ee	107	}
406c51ee	108
	109	return undef
	110	unless ( $banner = (${$me}{'net_pop3_banner'} =~ /(<.>)/)[0] );
	111
12df23ee	112	if (@_ <= 2) {
	113	($user, $pass) = $me->_lookup_credentials($user);
	114	}
406c51ee	115
406c51ee	116	$md->add($banner,$pass);
	117
	118	return undef
	119	unless($me->_APOP($user,$md->hexdigest));
	120
12df23ee	121	$me->_get_mailbox_count();
406c51ee	122	}
	123
	124	sub user
	125	{
	126	@_ == 2 or croak 'usage: $pop3->user( USER )';
	127	$_[0]->_USER($_[1]) ? 1 : undef;
	128	}
	129
	130	sub pass
	131	{
	132	@_ == 2 or croak 'usage: $pop3->pass( PASS )';
	133
	134	my($me,$pass) = @_;
	135
	136	return undef
	137	unless($me->_PASS($pass));
	138
12df23ee	139	$me->_get_mailbox_count();
406c51ee	140	}
	141
	142	sub reset
	143	{
	144	@_ == 1 or croak 'usage: $obj->reset()';
	145
	146	my $me = shift;
	147
	148	return 0
	149	unless($me->_RSET);
686337f3	150
406c51ee	151	if(defined ${*$me}{'net_pop3_mail'})
	152	{
	153	local $_;
	154	foreach (@{${*$me}{'net_pop3_mail'}})
	155	{
	156	delete $_->{'net_pop3_deleted'};
	157	}
	158	}
	159	}
	160
	161	sub last
	162	{
	163	@_ == 1 or croak 'usage: $obj->last()';
	164
	165	return undef
	166	unless $_[0]->_LAST && $_[0]->message =~ /(\d+)/;
	167
	168	return $1;
	169	}
	170
	171	sub top
	172	{
	173	@_ == 2 \|\| @_ == 3 or croak 'usage: $pop3->top( MSGNUM [, NUMLINES ])';
	174	my $me = shift;
	175
	176	return undef
	177	unless $me->_TOP($_[0], $_[1] \|\| 0);
	178
	179	$me->read_until_dot;
	180	}
	181
	182	sub popstat
	183	{
	184	@_ == 1 or croak 'usage: $pop3->popstat()';
	185	my $me = shift;
	186
	187	return ()
	188	unless $me->_STAT && $me->message =~ /(\d+)\D+(\d+)/;
	189
	190	($1 \|\| 0, $2 \|\| 0);
	191	}
	192
	193	sub list
	194	{
	195	@_ == 1 \|\| @_ == 2 or croak 'usage: $pop3->list( [ MSGNUM ] )';
	196	my $me = shift;
	197
	198	return undef
	199	unless $me->_LIST(@_);
	200
	201	if(@_)
	202	{
	203	$me->message =~ /\d+\D+(\d+)/;
	204	return $1 \|\| undef;
	205	}
686337f3	206
406c51ee	207	my $info = $me->read_until_dot
	208	or return undef;
	209
	210	my %hash = map { (/(\d+)\D+(\d+)/) } @$info;
	211
	212	return \%hash;
	213	}
	214
	215	sub get
	216	{
	217	@_ == 2 or @_ == 3 or croak 'usage: $pop3->get( MSGNUM [, FH ])';
	218	my $me = shift;
	219
	220	return undef
	221	unless $me->_RETR(shift);
	222
	223	$me->read_until_dot(@_);
	224	}
	225
12df23ee	226	sub getfh
	227	{
	228	@_ == 2 or croak 'usage: $pop3->getfh( MSGNUM )';
	229	my $me = shift;
	230
	231	return unless $me->_RETR(shift);
	232	return $me->tied_fh;
	233	}
	234
	235
	236
406c51ee	237	sub delete
	238	{
	239	@_ == 2 or croak 'usage: $pop3->delete( MSGNUM )';
f92f3fcb	240	my $me = shift;
	241	return 0 unless $me->_DELE(@_);
	242	${*$me}{'net_pop3_deleted'} = 1;
406c51ee	243	}
	244
	245	sub uidl
	246	{
	247	@_ == 1 \|\| @_ == 2 or croak 'usage: $pop3->uidl( [ MSGNUM ] )';
	248	my $me = shift;
	249	my $uidl;
	250
	251	$me->_UIDL(@_) or
	252	return undef;
	253	if(@_)
	254	{
	255	$uidl = ($me->message =~ /\d+\s+([\041-\176]+)/)[0];
	256	}
	257	else
	258	{
	259	my $ref = $me->read_until_dot
	260	or return undef;
	261	my $ln;
	262	$uidl = {};
	263	foreach $ln (@$ref) {
	264	my($msg,$uid) = $ln =~ /^\s*(\d+)\s+([\041-\176]+)/;
	265	$uidl->{$msg} = $uid;
	266	}
	267	}
	268	return $uidl;
	269	}
	270
	271	sub ping
	272	{
	273	@_ == 2 or croak 'usage: $pop3->ping( USER )';
	274	my $me = shift;
	275
	276	return () unless $me->_PING(@_) && $me->message =~ /(\d+)\D+(\d+)/;
	277
	278	($1 \|\| 0, $2 \|\| 0);
	279	}
	280
12df23ee	281	sub _lookup_credentials
	282	{
	283	my ($me, $user) = @_;
	284
	285	require Net::Netrc;
	286
	287	$user \|\|= eval { local $SIG{__DIE__}; (getpwuid($>))[0] } \|\|
	288	$ENV{NAME} \|\| $ENV{USER} \|\| $ENV{LOGNAME};
	289
	290	my $m = Net::Netrc->lookup(${*$me}{'net_pop3_host'},$user);
	291	$m \|\|= Net::Netrc->lookup(${*$me}{'net_pop3_host'});
	292
	293	my $pass = $m ? $m->password \|\| ""
	294	: "";
	295
	296	($user, $pass);
	297	}
	298
	299	sub _get_mailbox_count
	300	{
	301	my ($me) = @_;
	302	my $ret = ${*$me}{'net_pop3_count'} = ($me->message =~ /(\d+)\s+message/io)
	303	? $1 : ($me->popstat)[0];
	304
	305	$ret ? $ret : "0E0";
	306	}
	307
686337f3	308
406c51ee	309	sub _STAT { shift->command('STAT')->response() == CMD_OK }
	310	sub _LIST { shift->command('LIST',@_)->response() == CMD_OK }
	311	sub _RETR { shift->command('RETR',$_[0])->response() == CMD_OK }
	312	sub _DELE { shift->command('DELE',$_[0])->response() == CMD_OK }
	313	sub _NOOP { shift->command('NOOP')->response() == CMD_OK }
	314	sub _RSET { shift->command('RSET')->response() == CMD_OK }
	315	sub _QUIT { shift->command('QUIT')->response() == CMD_OK }
	316	sub _TOP { shift->command('TOP', @_)->response() == CMD_OK }
	317	sub _UIDL { shift->command('UIDL',@_)->response() == CMD_OK }
	318	sub _USER { shift->command('USER',$_[0])->response() == CMD_OK }
	319	sub _PASS { shift->command('PASS',$_[0])->response() == CMD_OK }
	320	sub _APOP { shift->command('APOP',@_)->response() == CMD_OK }
	321	sub _PING { shift->command('PING',$_[0])->response() == CMD_OK }
	322
	323	sub _RPOP { shift->command('RPOP',$_[0])->response() == CMD_OK }
	324	sub _LAST { shift->command('LAST')->response() == CMD_OK }
	325
f92f3fcb	326	sub _CAPA { shift->command('CAPA')->response() == CMD_OK }
f92f3fcb	327
406c51ee	328	sub quit
	329	{
	330	my $me = shift;
	331
	332	$me->_QUIT;
	333	$me->close;
	334	}
	335
	336	sub DESTROY
	337	{
	338	my $me = shift;
	339
f92f3fcb	340	if(defined fileno($me) and ${*$me}{'net_pop3_deleted'})
406c51ee	341	{
	342	$me->reset;
	343	$me->quit;
	344	}
	345	}
	346
	347	##
	348	## POP3 has weird responses, so we emulate them to look the same :-)
	349	##
	350
f92f3fcb	351	sub response {
	352	my $cmd = shift;
	353	my $str = $cmd->getline() or return undef;
	354	my $code = "500";
406c51ee	355
f92f3fcb	356	$cmd->debug_print(0, $str)
f92f3fcb	357	if ($cmd->debug);
406c51ee	358
f92f3fcb	359	if ($str =~ s/^\+OK\s*//io) {
f92f3fcb	360	$code = "200";
406c51ee	361	}
f92f3fcb	362	elsif ($str =~ s/^\+\s*//io) {
	363	$code = "300";
	364	}
	365	else {
	366	$str =~ s/^-ERR\s*//io;
406c51ee	367	}
406c51ee	368
f92f3fcb	369	${*$cmd}{'net_cmd_resp'} = [$str];
f92f3fcb	370	${*$cmd}{'net_cmd_code'} = $code;
406c51ee	371
f92f3fcb	372	substr($code, 0, 1);
	373	}
	374
	375
	376	sub capa {
	377	my $this = shift;
	378	my ($capa, %capabilities);
	379
	380	# Fake a capability here
	381	$capabilities{APOP} = '' if ($this->banner() =~ /<.*>/);
	382
7cf5cf7c	383	if ($this->_CAPA()) {
	384	$capabilities{CAPA} = 1;
	385	$capa = $this->read_until_dot();
	386	%capabilities = (%capabilities, map { /^\s(\S+)\s(.*)/ } @$capa);
	387	}
	388	else {
	389	# Check AUTH for SASL capabilities
	390	if ( $this->command('AUTH')->response() == CMD_OK ) {
	391	my $mechanism = $this->read_until_dot();
	392	$capabilities{SASL} = join " ", map { m/([A-Z0-9_-]+)/ } @{ $mechanism };
	393	}
	394	}
	395
f92f3fcb	396	return ${*$this}{'net_pop3e_capabilities'} = \%capabilities;
	397	}
	398
	399	sub capabilities {
	400	my $this = shift;
	401
	402	${*$this}{'net_pop3e_capabilities'} \|\| $this->capa;
	403	}
	404
	405	sub auth {
	406	my ($self, $username, $password) = @_;
	407
	408	eval {
	409	require MIME::Base64;
	410	require Authen::SASL;
9714c667	411	} or $self->set_status(500,["Need MIME::Base64 and Authen::SASL todo auth"]), return 0;
f92f3fcb	412
	413	my $capa = $self->capa;
	414	my $mechanisms = $capa->{SASL} \|\| 'CRAM-MD5';
	415
	416	my $sasl;
	417
	418	if (ref($username) and UNIVERSAL::isa($username,'Authen::SASL')) {
	419	$sasl = $username;
7cf5cf7c	420	my $user_mech = $sasl->mechanism \|\| '';
	421	my @user_mech = split(/\s+/, $user_mech);
	422	my %user_mech; @user_mech{@user_mech} = ();
	423
	424	my @server_mech = split(/\s+/,$mechanisms);
	425	my @mech = @user_mech
	426	? grep { exists $user_mech{$_} } @server_mech
	427	: @server_mech;
	428	unless (@mech) {
	429	$self->set_status(500,
	430	[ 'Client SASL mechanisms (',
	431	join(', ', @user_mech),
	432	') do not match the SASL mechnism the server announces (',
	433	join(', ', @server_mech), ')',
	434	]);
	435	return 0;
	436	}
	437
	438	$sasl->mechanism(join(" ",@mech));
f92f3fcb	439	}
	440	else {
	441	die "auth(username, password)" if not length $username;
	442	$sasl = Authen::SASL->new(mechanism=> $mechanisms,
	443	callback => { user => $username,
	444	pass => $password,
	445	authname => $username,
	446	});
	447	}
	448
	449	# We should probably allow the user to pass the host, but I don't
	450	# currently know and SASL mechanisms that are used by smtp that need it
7cf5cf7c	451	my ( $hostname ) = split /:/ , ${*$self}{'net_pop3_host'};
	452	my $client = eval { $sasl->client_new('pop',$hostname,0) };
	453
	454	unless ($client) {
	455	my $mech = $sasl->mechanism;
	456	$self->set_status(500, [
	457	" Authen::SASL failure: $@",
	458	'(please check if your local Authen::SASL installation',
	459	"supports mechanism '$mech'"
	460	]);
	461	return 0;
	462	}
	463
	464	my ($token) = $client->client_start
	465	or do {
	466	my $mech = $client->mechanism;
	467	$self->set_status(500, [
	468	' Authen::SASL failure: $client->client_start ',
	469	"mechanism '$mech' hostname #$hostname#",
	470	$client->error
	471	]);
	472	return 0;
	473	};
f92f3fcb	474
	475	# We dont support sasl mechanisms that encrypt the socket traffic.
	476	# todo that we would really need to change the ISA hierarchy
	477	# so we dont inherit from IO::Socket, but instead hold it in an attribute
	478
	479	my @cmd = ("AUTH", $client->mechanism);
	480	my $code;
	481
7cf5cf7c	482	push @cmd, MIME::Base64::encode_base64($token,'')
7cf5cf7c	483	if defined $token and length $token;
f92f3fcb	484
f92f3fcb	485	while (($code = $self->command(@cmd)->response()) == CMD_MORE) {
7cf5cf7c	486
	487	my ( $token ) = $client->client_step(
	488	MIME::Base64::decode_base64(
	489	($self->message)[0]
	490	)
	491	) or do {
	492	$self->set_status(500, [
	493	' Authen::SASL failure: $client->client_step ',
	494	"mechanism '", $client->mechanism ," hostname #$hostname#, ",
	495	$client->error
	496	]);
	497	return 0;
	498	};
	499
f92f3fcb	500	@cmd = (MIME::Base64::encode_base64(
7cf5cf7c	501	defined $token ? $token : '',
	502	''
	503	)
	504	);
f92f3fcb	505	}
	506
	507	$code == CMD_OK;
	508	}
	509
	510	sub banner {
	511	my $this = shift;
	512
	513	return ${*$this}{'net_pop3_banner'};
406c51ee	514	}
	515
	516	1;
	517
	518	__END__
	519
	520	=head1 NAME
	521
12df23ee	522	Net::POP3 - Post Office Protocol 3 Client class (RFC1939)
406c51ee	523
	524	=head1 SYNOPSIS
	525
	526	use Net::POP3;
686337f3	527
406c51ee	528	# Constructors
	529	$pop = Net::POP3->new('pop3host');
	530	$pop = Net::POP3->new('pop3host', Timeout => 60);
	531
dea4d7df	532	if ($pop->login($username, $password) > 0) {
	533	my $msgnums = $pop->list; # hashref of msgnum => size
	534	foreach my $msgnum (keys %$msgnums) {
	535	my $msg = $pop->get($msgnum);
	536	print @$msg;
	537	$pop->delete($msgnum);
	538	}
	539	}
	540
	541	$pop->quit;
	542
406c51ee	543	=head1 DESCRIPTION
	544
	545	This module implements a client interface to the POP3 protocol, enabling
	546	a perl5 application to talk to POP3 servers. This documentation assumes
12df23ee	547	that you are familiar with the POP3 protocol described in RFC1939.
406c51ee	548
	549	A new Net::POP3 object must be created with the I<new> method. Once
	550	this has been done, all POP3 commands are accessed via method calls
	551	on the object.
	552
406c51ee	553	=head1 CONSTRUCTOR
	554
	555	=over 4
	556
f92f3fcb	557	=item new ( [ HOST ] [, OPTIONS ] 0
406c51ee	558
406c51ee	559	This is the constructor for a new Net::POP3 object. C<HOST> is the
f92f3fcb	560	name of the remote host to which an POP3 connection is required.
406c51ee	561
f92f3fcb	562	C<HOST> is optional. If C<HOST> is not given then it may instead be
	563	passed as the C<Host> option described below. If neither is given then
	564	the C<POP3_Hosts> specified in C<Net::Config> will be used.
406c51ee	565
	566	C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
	567	Possible options are:
	568
f92f3fcb	569	B<Host> - POP3 host to connect to. It may be a single scalar, as defined for
	570	the C<PeerAddr> option in L<IO::Socket::INET>, or a reference to
	571	an array with hosts to try in turn. The L</host> method will return the value
	572	which was used to connect to the host.
	573
406c51ee	574	B<ResvPort> - If given then the socket for the C<Net::POP3> object
	575	will be bound to the local port given using C<bind> when the socket is
	576	created.
	577
	578	B<Timeout> - Maximum time, in seconds, to wait for a response from the
	579	POP3 server (default: 120)
	580
	581	B<Debug> - Enable debugging information
	582
	583	=back
	584
	585	=head1 METHODS
	586
	587	Unless otherwise stated all methods return either a I<true> or I<false>
	588	value, with I<true> meaning that the operation was a success. When a method
	589	states that it returns a value, failure will be returned as I<undef> or an
	590	empty list.
	591
	592	=over 4
	593
f92f3fcb	594	=item auth ( USERNAME, PASSWORD )
	595
	596	Attempt SASL authentication.
	597
406c51ee	598	=item user ( USER )
	599
	600	Send the USER command.
	601
	602	=item pass ( PASS )
	603
	604	Send the PASS command. Returns the number of messages in the mailbox.
	605
	606	=item login ( [ USER [, PASS ]] )
	607
d1be9408	608	Send both the USER and PASS commands. If C<PASS> is not given the
406c51ee	609	C<Net::POP3> uses C<Net::Netrc> to lookup the password using the host
	610	and username. If the username is not specified then the current user name
	611	will be used.
	612
	613	Returns the number of messages in the mailbox. However if there are no
	614	messages on the server the string C<"0E0"> will be returned. This is
	615	will give a true value in a boolean context, but zero in a numeric context.
	616
	617	If there was an error authenticating the user then I<undef> will be returned.
	618
12df23ee	619	=item apop ( [ USER [, PASS ]] )
406c51ee	620
406c51ee	621	Authenticate with the server identifying as C<USER> with password C<PASS>.
12df23ee	622	Similar to L</login>, but the password is not sent in clear text.
406c51ee	623
12df23ee	624	To use this method you must have the Digest::MD5 or the MD5 module installed,
12df23ee	625	otherwise this method will return I<undef>.
406c51ee	626
f92f3fcb	627	=item banner ()
	628
	629	Return the sever's connection banner
	630
	631	=item capa ()
	632
3c4b39be	633	Return a reference to a hash of the capabilities of the server. APOP
f92f3fcb	634	is added as a pseudo capability. Note that I've been unable to
	635	find a list of the standard capability values, and some appear to
	636	be multi-word and some are not. We make an attempt at intelligently
	637	parsing them, but it may not be correct.
	638
	639	=item capabilities ()
	640
	641	Just like capa, but only uses a cache from the last time we asked
	642	the server, so as to avoid asking more than once.
	643
406c51ee	644	=item top ( MSGNUM [, NUMLINES ] )
	645
	646	Get the header and the first C<NUMLINES> of the body for the message
	647	C<MSGNUM>. Returns a reference to an array which contains the lines of text
	648	read from the server.
	649
	650	=item list ( [ MSGNUM ] )
	651
	652	If called with an argument the C<list> returns the size of the message
	653	in octets.
	654
	655	If called without arguments a reference to a hash is returned. The
	656	keys will be the C<MSGNUM>'s of all undeleted messages and the values will
	657	be their size in octets.
	658
	659	=item get ( MSGNUM [, FH ] )
	660
	661	Get the message C<MSGNUM> from the remote mailbox. If C<FH> is not given
	662	then get returns a reference to an array which contains the lines of
	663	text read from the server. If C<FH> is given then the lines returned
	664	from the server are printed to the filehandle C<FH>.
	665
12df23ee	666	=item getfh ( MSGNUM )
	667
	668	As per get(), but returns a tied filehandle. Reading from this
	669	filehandle returns the requested message. The filehandle will return
	670	EOF at the end of the message and should not be reused.
	671
406c51ee	672	=item last ()
	673
	674	Returns the highest C<MSGNUM> of all the messages accessed.
	675
	676	=item popstat ()
	677
	678	Returns a list of two elements. These are the number of undeleted
	679	elements and the size of the mbox in octets.
	680
	681	=item ping ( USER )
	682
	683	Returns a list of two elements. These are the number of new messages
	684	and the total number of messages for C<USER>.
	685
	686	=item uidl ( [ MSGNUM ] )
	687
	688	Returns a unique identifier for C<MSGNUM> if given. If C<MSGNUM> is not
	689	given C<uidl> returns a reference to a hash where the keys are the
	690	message numbers and the values are the unique identifiers.
	691
	692	=item delete ( MSGNUM )
	693
	694	Mark message C<MSGNUM> to be deleted from the remote mailbox. All messages
	695	that are marked to be deleted will be removed from the remote mailbox
	696	when the server connection closed.
	697
	698	=item reset ()
	699
3c4b39be	700	Reset the status of the remote POP3 server. This includes resetting the
406c51ee	701	status of all messages to not be deleted.
	702
	703	=item quit ()
	704
	705	Quit and close the connection to the remote POP3 server. Any messages marked
	706	as deleted will be deleted from the remote mailbox.
	707
	708	=back
	709
	710	=head1 NOTES
	711
	712	If a C<Net::POP3> object goes out of scope before C<quit> method is called
	713	then the C<reset> method will called before the connection is closed. This
	714	means that any messages marked to be deleted will not be.
	715
	716	=head1 SEE ALSO
	717
12df23ee	718	L<Net::Netrc>,
406c51ee	719	L<Net::Cmd>
	720
	721	=head1 AUTHOR
	722
	723	Graham Barr <gbarr@pobox.com>
	724
	725	=head1 COPYRIGHT
	726
f92f3fcb	727	Copyright (c) 1995-2003 Graham Barr. All rights reserved.
406c51ee	728	This program is free software; you can redistribute it and/or modify
	729	it under the same terms as Perl itself.
	730
	731	=cut