[perl5.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";

@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() =~ /<.*>/);

    return \%capabilities unless $this->_CAPA();

    $capa = $this->read_until_dot();
    %capabilities = map { /^\s*(\S+)\s*(.*)/ } @$capa;
    $capabilities{APOP} = '' if ($this->banner() =~ /<.*>/);

    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;
      $sasl->mechanism($mechanisms);
    }
    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 $client = $sasl->client_new('pop3',${*$self}{'net_pop3_host'},0);
    my $str    = $client->client_start;

    # 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($str,'')
      if defined $str and length $str;

    while (($code = $self->command(@cmd)->response()) == CMD_MORE) {
      @cmd = (MIME::Base64::encode_base64(
	$client->client_step(
	  MIME::Base64::decode_base64(
	    ($self->message)[0]
	  )
	), ''
      ));
    }

    $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 JH	1	# Net::POP3.pm
406c51ee JH	2	#
f92f3fcb	3	# Copyright (c) 1995-2004 Graham Barr <gbarr@pobox.com>. All rights reserved.
406c51ee JH	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
9714c667	16	$VERSION = "2.28";
406c51ee JH	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 GB	24	my ($host,%arg);
	25	if (@_ % 2) {
	26	$host = shift ;
	27	%arg = @_;
	28	} else {
	29	%arg = @_;
	30	$host=delete $arg{Host};
	31	}
406c51ee JH	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 GB	68	sub host {
	69	my $me = shift;
	70	${*$me}{'net_pop3_host'};
	71	}
	72
406c51ee JH	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 GB	85	if (@_ <= 2) {
	86	($user, $pass) = $me->_lookup_credentials($user);
	87	}
406c51ee JH	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 GB	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 JH	108
	109	return undef
	110	unless ( $banner = (${$me}{'net_pop3_banner'} =~ /(<.>)/)[0] );
	111
12df23ee GB	112	if (@_ <= 2) {
	113	($user, $pass) = $me->_lookup_credentials($user);
	114	}
406c51ee	115
406c51ee JH	116	$md->add($banner,$pass);
	117
	118	return undef
	119	unless($me->_APOP($user,$md->hexdigest));
	120
12df23ee	121	$me->_get_mailbox_count();
406c51ee JH	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 JH	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 JH	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 JH	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 GB	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 JH	237	sub delete
	238	{
	239	@_ == 2 or croak 'usage: $pop3->delete( MSGNUM )';
f92f3fcb GB	240	my $me = shift;
	241	return 0 unless $me->_DELE(@_);
	242	${*$me}{'net_pop3_deleted'} = 1;
406c51ee JH	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 GB	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 JH	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 GB	326	sub _CAPA { shift->command('CAPA')->response() == CMD_OK }
f92f3fcb GB	327
406c51ee JH	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 JH	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 GB	351	sub response {
	352	my $cmd = shift;
	353	my $str = $cmd->getline() or return undef;
	354	my $code = "500";
406c51ee	355
f92f3fcb GB	356	$cmd->debug_print(0, $str)
f92f3fcb GB	357	if ($cmd->debug);
406c51ee	358
f92f3fcb GB	359	if ($str =~ s/^\+OK\s*//io) {
f92f3fcb GB	360	$code = "200";
406c51ee	361	}
f92f3fcb GB	362	elsif ($str =~ s/^\+\s*//io) {
	363	$code = "300";
	364	}
	365	else {
	366	$str =~ s/^-ERR\s*//io;
406c51ee JH	367	}
406c51ee JH	368
f92f3fcb GB	369	${*$cmd}{'net_cmd_resp'} = [$str];
f92f3fcb GB	370	${*$cmd}{'net_cmd_code'} = $code;
406c51ee	371
f92f3fcb GB	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
	383	return \%capabilities unless $this->_CAPA();
	384
	385	$capa = $this->read_until_dot();
	386	%capabilities = map { /^\s(\S+)\s(.*)/ } @$capa;
	387	$capabilities{APOP} = '' if ($this->banner() =~ /<.*>/);
	388
	389	return ${*$this}{'net_pop3e_capabilities'} = \%capabilities;
	390	}
	391
	392	sub capabilities {
	393	my $this = shift;
	394
	395	${*$this}{'net_pop3e_capabilities'} \|\| $this->capa;
	396	}
	397
	398	sub auth {
	399	my ($self, $username, $password) = @_;
	400
	401	eval {
	402	require MIME::Base64;
	403	require Authen::SASL;
9714c667	404	} or $self->set_status(500,["Need MIME::Base64 and Authen::SASL todo auth"]), return 0;
f92f3fcb GB	405
	406	my $capa = $self->capa;
	407	my $mechanisms = $capa->{SASL} \|\| 'CRAM-MD5';
	408
	409	my $sasl;
	410
	411	if (ref($username) and UNIVERSAL::isa($username,'Authen::SASL')) {
	412	$sasl = $username;
	413	$sasl->mechanism($mechanisms);
	414	}
	415	else {
	416	die "auth(username, password)" if not length $username;
	417	$sasl = Authen::SASL->new(mechanism=> $mechanisms,
	418	callback => { user => $username,
	419	pass => $password,
	420	authname => $username,
	421	});
	422	}
	423
	424	# We should probably allow the user to pass the host, but I don't
	425	# currently know and SASL mechanisms that are used by smtp that need it
	426	my $client = $sasl->client_new('pop3',${*$self}{'net_pop3_host'},0);
	427	my $str = $client->client_start;
	428
	429	# We dont support sasl mechanisms that encrypt the socket traffic.
	430	# todo that we would really need to change the ISA hierarchy
	431	# so we dont inherit from IO::Socket, but instead hold it in an attribute
	432
	433	my @cmd = ("AUTH", $client->mechanism);
	434	my $code;
	435
	436	push @cmd, MIME::Base64::encode_base64($str,'')
	437	if defined $str and length $str;
	438
	439	while (($code = $self->command(@cmd)->response()) == CMD_MORE) {
	440	@cmd = (MIME::Base64::encode_base64(
	441	$client->client_step(
	442	MIME::Base64::decode_base64(
	443	($self->message)[0]
	444	)
	445	), ''
	446	));
	447	}
	448
	449	$code == CMD_OK;
	450	}
	451
	452	sub banner {
	453	my $this = shift;
	454
	455	return ${*$this}{'net_pop3_banner'};
406c51ee JH	456	}
	457
	458	1;
	459
	460	__END__
	461
	462	=head1 NAME
	463
12df23ee	464	Net::POP3 - Post Office Protocol 3 Client class (RFC1939)
406c51ee JH	465
	466	=head1 SYNOPSIS
	467
	468	use Net::POP3;
686337f3	469
406c51ee JH	470	# Constructors
	471	$pop = Net::POP3->new('pop3host');
	472	$pop = Net::POP3->new('pop3host', Timeout => 60);
	473
dea4d7df GB	474	if ($pop->login($username, $password) > 0) {
	475	my $msgnums = $pop->list; # hashref of msgnum => size
	476	foreach my $msgnum (keys %$msgnums) {
	477	my $msg = $pop->get($msgnum);
	478	print @$msg;
	479	$pop->delete($msgnum);
	480	}
	481	}
	482
	483	$pop->quit;
	484
406c51ee JH	485	=head1 DESCRIPTION
	486
	487	This module implements a client interface to the POP3 protocol, enabling
	488	a perl5 application to talk to POP3 servers. This documentation assumes
12df23ee	489	that you are familiar with the POP3 protocol described in RFC1939.
406c51ee JH	490
	491	A new Net::POP3 object must be created with the I<new> method. Once
	492	this has been done, all POP3 commands are accessed via method calls
	493	on the object.
	494
406c51ee JH	495	=head1 CONSTRUCTOR
	496
	497	=over 4
	498
f92f3fcb	499	=item new ( [ HOST ] [, OPTIONS ] 0
406c51ee JH	500
406c51ee JH	501	This is the constructor for a new Net::POP3 object. C<HOST> is the
f92f3fcb	502	name of the remote host to which an POP3 connection is required.
406c51ee	503
f92f3fcb GB	504	C<HOST> is optional. If C<HOST> is not given then it may instead be
	505	passed as the C<Host> option described below. If neither is given then
	506	the C<POP3_Hosts> specified in C<Net::Config> will be used.
406c51ee JH	507
	508	C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
	509	Possible options are:
	510
f92f3fcb GB	511	B<Host> - POP3 host to connect to. It may be a single scalar, as defined for
	512	the C<PeerAddr> option in L<IO::Socket::INET>, or a reference to
	513	an array with hosts to try in turn. The L</host> method will return the value
	514	which was used to connect to the host.
	515
406c51ee JH	516	B<ResvPort> - If given then the socket for the C<Net::POP3> object
	517	will be bound to the local port given using C<bind> when the socket is
	518	created.
	519
	520	B<Timeout> - Maximum time, in seconds, to wait for a response from the
	521	POP3 server (default: 120)
	522
	523	B<Debug> - Enable debugging information
	524
	525	=back
	526
	527	=head1 METHODS
	528
	529	Unless otherwise stated all methods return either a I<true> or I<false>
	530	value, with I<true> meaning that the operation was a success. When a method
	531	states that it returns a value, failure will be returned as I<undef> or an
	532	empty list.
	533
	534	=over 4
	535
f92f3fcb GB	536	=item auth ( USERNAME, PASSWORD )
	537
	538	Attempt SASL authentication.
	539
406c51ee JH	540	=item user ( USER )
	541
	542	Send the USER command.
	543
	544	=item pass ( PASS )
	545
	546	Send the PASS command. Returns the number of messages in the mailbox.
	547
	548	=item login ( [ USER [, PASS ]] )
	549
d1be9408	550	Send both the USER and PASS commands. If C<PASS> is not given the
406c51ee JH	551	C<Net::POP3> uses C<Net::Netrc> to lookup the password using the host
	552	and username. If the username is not specified then the current user name
	553	will be used.
	554
	555	Returns the number of messages in the mailbox. However if there are no
	556	messages on the server the string C<"0E0"> will be returned. This is
	557	will give a true value in a boolean context, but zero in a numeric context.
	558
	559	If there was an error authenticating the user then I<undef> will be returned.
	560
12df23ee	561	=item apop ( [ USER [, PASS ]] )
406c51ee JH	562
406c51ee JH	563	Authenticate with the server identifying as C<USER> with password C<PASS>.
12df23ee	564	Similar to L</login>, but the password is not sent in clear text.
406c51ee	565
12df23ee GB	566	To use this method you must have the Digest::MD5 or the MD5 module installed,
12df23ee GB	567	otherwise this method will return I<undef>.
406c51ee	568
f92f3fcb GB	569	=item banner ()
	570
	571	Return the sever's connection banner
	572
	573	=item capa ()
	574
3c4b39be	575	Return a reference to a hash of the capabilities of the server. APOP
f92f3fcb GB	576	is added as a pseudo capability. Note that I've been unable to
	577	find a list of the standard capability values, and some appear to
	578	be multi-word and some are not. We make an attempt at intelligently
	579	parsing them, but it may not be correct.
	580
	581	=item capabilities ()
	582
	583	Just like capa, but only uses a cache from the last time we asked
	584	the server, so as to avoid asking more than once.
	585
406c51ee JH	586	=item top ( MSGNUM [, NUMLINES ] )
	587
	588	Get the header and the first C<NUMLINES> of the body for the message
	589	C<MSGNUM>. Returns a reference to an array which contains the lines of text
	590	read from the server.
	591
	592	=item list ( [ MSGNUM ] )
	593
	594	If called with an argument the C<list> returns the size of the message
	595	in octets.
	596
	597	If called without arguments a reference to a hash is returned. The
	598	keys will be the C<MSGNUM>'s of all undeleted messages and the values will
	599	be their size in octets.
	600
	601	=item get ( MSGNUM [, FH ] )
	602
	603	Get the message C<MSGNUM> from the remote mailbox. If C<FH> is not given
	604	then get returns a reference to an array which contains the lines of
	605	text read from the server. If C<FH> is given then the lines returned
	606	from the server are printed to the filehandle C<FH>.
	607
12df23ee GB	608	=item getfh ( MSGNUM )
	609
	610	As per get(), but returns a tied filehandle. Reading from this
	611	filehandle returns the requested message. The filehandle will return
	612	EOF at the end of the message and should not be reused.
	613
406c51ee JH	614	=item last ()
	615
	616	Returns the highest C<MSGNUM> of all the messages accessed.
	617
	618	=item popstat ()
	619
	620	Returns a list of two elements. These are the number of undeleted
	621	elements and the size of the mbox in octets.
	622
	623	=item ping ( USER )
	624
	625	Returns a list of two elements. These are the number of new messages
	626	and the total number of messages for C<USER>.
	627
	628	=item uidl ( [ MSGNUM ] )
	629
	630	Returns a unique identifier for C<MSGNUM> if given. If C<MSGNUM> is not
	631	given C<uidl> returns a reference to a hash where the keys are the
	632	message numbers and the values are the unique identifiers.
	633
	634	=item delete ( MSGNUM )
	635
	636	Mark message C<MSGNUM> to be deleted from the remote mailbox. All messages
	637	that are marked to be deleted will be removed from the remote mailbox
	638	when the server connection closed.
	639
	640	=item reset ()
	641
3c4b39be	642	Reset the status of the remote POP3 server. This includes resetting the
406c51ee JH	643	status of all messages to not be deleted.
	644
	645	=item quit ()
	646
	647	Quit and close the connection to the remote POP3 server. Any messages marked
	648	as deleted will be deleted from the remote mailbox.
	649
	650	=back
	651
	652	=head1 NOTES
	653
	654	If a C<Net::POP3> object goes out of scope before C<quit> method is called
	655	then the C<reset> method will called before the connection is closed. This
	656	means that any messages marked to be deleted will not be.
	657
	658	=head1 SEE ALSO
	659
12df23ee	660	L<Net::Netrc>,
406c51ee JH	661	L<Net::Cmd>
	662
	663	=head1 AUTHOR
	664
	665	Graham Barr <gbarr@pobox.com>
	666
	667	=head1 COPYRIGHT
	668
f92f3fcb	669	Copyright (c) 1995-2003 Graham Barr. All rights reserved.
406c51ee JH	670	This program is free software; you can redistribute it and/or modify
	671	it under the same terms as Perl itself.
	672
	673	=cut