/linkedfs/usr/lib/perl5/5.8.6/Net/POP3.pm
Perl | 673 lines | 501 code | 153 blank | 19 comment | 82 complexity | 8f8b90f41fdcc32afbd94561de72f6e2 MD5 | raw file
Possible License(s): GPL-2.0, MIT, LGPL-3.0
- # 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