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 capabilties 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 reseting 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
Revision:	1.1
Committed:	Thu Jun 30 14:27:14 2005 UTC (21 years, 3 months ago) by root
Branch:	MAIN
CVS Tags:	PERL-5-8-7, HEAD
Branch point for:	PERL
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.1	# Net::POP3.pm
2			#
3			# Copyright (c) 1995-2004 Graham Barr <gbarr@pobox.com>. All rights reserved.
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
16			$VERSION = "2.28";
17
18			@ISA = qw(Net::Cmd IO::Socket::INET);
19
20			sub new
21			{
22			my $self = shift;
23			my $type = ref($self) \|\| $self;
24			my ($host,%arg);
25			if (@_ % 2) {
26			$host = shift ;
27			%arg = @_;
28			} else {
29			%arg = @_;
30			$host=delete $arg{Host};
31			}
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
68			sub host {
69			my $me = shift;
70			${*$me}{'net_pop3_host'};
71			}
72
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
85			if (@_ <= 2) {
86			($user, $pass) = $me->_lookup_credentials($user);
87			}
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;
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";
106			return undef;
107			}
108
109			return undef
110			unless ( $banner = (${$me}{'net_pop3_banner'} =~ /(<.>)/)[0] );
111
112			if (@_ <= 2) {
113			($user, $pass) = $me->_lookup_credentials($user);
114			}
115
116			$md->add($banner,$pass);
117
118			return undef
119			unless($me->_APOP($user,$md->hexdigest));
120
121			$me->_get_mailbox_count();
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
139			$me->_get_mailbox_count();
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);
150
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			}
206
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
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
237			sub delete
238			{
239			@_ == 2 or croak 'usage: $pop3->delete( MSGNUM )';
240			my $me = shift;
241			return 0 unless $me->_DELE(@_);
242			${*$me}{'net_pop3_deleted'} = 1;
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
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
308
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
326			sub _CAPA { shift->command('CAPA')->response() == CMD_OK }
327
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
340			if(defined fileno($me) and ${*$me}{'net_pop3_deleted'})
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
351			sub response {
352			my $cmd = shift;
353			my $str = $cmd->getline() or return undef;
354			my $code = "500";
355
356			$cmd->debug_print(0, $str)
357			if ($cmd->debug);
358
359			if ($str =~ s/^\+OK\s*//io) {
360			$code = "200";
361			}
362			elsif ($str =~ s/^\+\s*//io) {
363			$code = "300";
364			}
365			else {
366			$str =~ s/^-ERR\s*//io;
367			}
368
369			${*$cmd}{'net_cmd_resp'} = [$str];
370			${*$cmd}{'net_cmd_code'} = $code;
371
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;
404			} or $self->set_status(500,["Need MIME::Base64 and Authen::SASL todo auth"]), return 0;
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'};
456			}
457
458			1;
459
460			__END__
461
462			=head1 NAME
463
464			Net::POP3 - Post Office Protocol 3 Client class (RFC1939)
465
466			=head1 SYNOPSIS
467
468			use Net::POP3;
469
470			# Constructors
471			$pop = Net::POP3->new('pop3host');
472			$pop = Net::POP3->new('pop3host', Timeout => 60);
473
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
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
489			that you are familiar with the POP3 protocol described in RFC1939.
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
495			=head1 CONSTRUCTOR
496
497			=over 4
498
499			=item new ( [ HOST ] [, OPTIONS ] 0
500
501			This is the constructor for a new Net::POP3 object. C<HOST> is the
502			name of the remote host to which an POP3 connection is required.
503
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.
507
508			C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
509			Possible options are:
510
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
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
536			=item auth ( USERNAME, PASSWORD )
537
538			Attempt SASL authentication.
539
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
550			Send both the USER and PASS commands. If C<PASS> is not given the
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
561			=item apop ( [ USER [, PASS ]] )
562
563			Authenticate with the server identifying as C<USER> with password C<PASS>.
564			Similar to L</login>, but the password is not sent in clear text.
565
566			To use this method you must have the Digest::MD5 or the MD5 module installed,
567			otherwise this method will return I<undef>.
568
569			=item banner ()
570
571			Return the sever's connection banner
572
573			=item capa ()
574
575			Return a reference to a hash of the capabilties of the server. APOP
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
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
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
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
642			Reset the status of the remote POP3 server. This includes reseting the
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
660			L<Net::Netrc>,
661			L<Net::Cmd>
662
663			=head1 AUTHOR
664
665			Graham Barr <gbarr@pobox.com>
666
667			=head1 COPYRIGHT
668
669			Copyright (c) 1995-2003 Graham Barr. All rights reserved.
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