1 # Net::POP3.pm

     2 #

     3 # Copyright (c) 1995-1997 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.24"; # $Id: //depot/libnet/Net/POP3.pm#24 $

    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 = shift if @_ % 2;

    25  my %arg  = @_; 

    26  my $hosts = defined $host ? [ $host ] : $NetConfig{pop3_hosts};

    27  my $obj;

    28  my @localport = exists $arg{ResvPort} ? ( LocalPort => $arg{ResvPort} ): ();

    29 

    30  my $h;

    31  foreach $h (@{$hosts})

    32   {

    33    $obj = $type->SUPER::new(PeerAddr => ($host = $h), 

    34 			    PeerPort => $arg{Port} || 'pop3(110)',

    35 			    Proto    => 'tcp',

    36 			    @localport,

    37 			    Timeout  => defined $arg{Timeout}

    38 						? $arg{Timeout}

    39 						: 120

    40 			   ) and last;

    41   }

    42 

    43  return undef

    44 	unless defined $obj;

    45 

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

    47 

    48  $obj->autoflush(1);

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

    50 

    51  unless ($obj->response() == CMD_OK)

    52   {

    53    $obj->close();

    54    return undef;

    55   }

    56 

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

    58 

    59  $obj;

    60 }

    61 

    62 ##

    63 ## We don't want people sending me their passwords when they report problems

    64 ## now do we :-)

    65 ##

    66 

    67 sub debug_text { $_[2] =~ /^(pass|rpop)/i ? "$1 ....\n" : $_[2]; }

    68 

    69 sub login

    70 {

    71  @_ >= 1 && @_ <= 3 or croak 'usage: $pop3->login( USER, PASS )';

    72  my($me,$user,$pass) = @_;

    73 

    74  if (@_ <= 2) {

    75    ($user, $pass) = $me->_lookup_credentials($user);

    76  }

    77 

    78  $me->user($user) and

    79     $me->pass($pass);

    80 }

    81 

    82 sub apop

    83 {

    84  @_ >= 1 && @_ <= 3 or croak 'usage: $pop3->apop( USER, PASS )';

    85  my($me,$user,$pass) = @_;

    86  my $banner;

    87  my $md;

    88 

    89  if (eval { local $SIG{__DIE__}; require Digest::MD5 }) {

    90    $md = Digest::MD5->new();

    91  } elsif (eval { local $SIG{__DIE__}; require MD5 }) {

    92    $md = MD5->new();

    93  } else {

    94    carp "You need to install Digest::MD5 or MD5 to use the APOP command";

    95    return undef;

    96  }

    97 

    98  return undef

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

   100 

   101  if (@_ <= 2) {

   102    ($user, $pass) = $me->_lookup_credentials($user);

   103  }

   104 

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

   106 

   107  return undef

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

   109 

   110  $me->_get_mailbox_count();

   111 }

   112 

   113 sub user

   114 {

   115  @_ == 2 or croak 'usage: $pop3->user( USER )';

   116  $_[0]->_USER($_[1]) ? 1 : undef;

   117 }

   118 

   119 sub pass

   120 {

   121  @_ == 2 or croak 'usage: $pop3->pass( PASS )';

   122 

   123  my($me,$pass) = @_;

   124 

   125  return undef

   126    unless($me->_PASS($pass));

   127 

   128  $me->_get_mailbox_count();

   129 }

   130 

   131 sub reset

   132 {

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

   134 

   135  my $me = shift;

   136 

   137  return 0 

   138    unless($me->_RSET);

   139 

   140  if(defined ${*$me}{'net_pop3_mail'})

   141   {

   142    local $_;

   143    foreach (@{${*$me}{'net_pop3_mail'}})

   144     {

   145      delete $_->{'net_pop3_deleted'};

   146     }

   147   }

   148 }

   149 

   150 sub last

   151 {

   152  @_ == 1 or croak 'usage: $obj->last()';

   153 

   154  return undef

   155     unless $_[0]->_LAST && $_[0]->message =~ /(\d+)/;

   156 

   157  return $1;

   158 }

   159 

   160 sub top

   161 {

   162  @_ == 2 || @_ == 3 or croak 'usage: $pop3->top( MSGNUM [, NUMLINES ])';

   163  my $me = shift;

   164 

   165  return undef

   166     unless $me->_TOP($_[0], $_[1] || 0);

   167 

   168  $me->read_until_dot;

   169 }

   170 

   171 sub popstat

   172 {

   173  @_ == 1 or croak 'usage: $pop3->popstat()';

   174  my $me = shift;

   175 

   176  return ()

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

   178 

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

   180 }

   181 

   182 sub list

   183 {

   184  @_ == 1 || @_ == 2 or croak 'usage: $pop3->list( [ MSGNUM ] )';

   185  my $me = shift;

   186 

   187  return undef

   188     unless $me->_LIST(@_);

   189 

   190  if(@_)

   191   {

   192    $me->message =~ /\d+\D+(\d+)/;

   193    return $1 || undef;

   194   }

   195 

   196  my $info = $me->read_until_dot

   197 	or return undef;

   198 

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

   200 

   201  return \%hash;

   202 }

   203 

   204 sub get

   205 {

   206  @_ == 2 or @_ == 3 or croak 'usage: $pop3->get( MSGNUM [, FH ])';

   207  my $me = shift;

   208 

   209  return undef

   210     unless $me->_RETR(shift);

   211 

   212  $me->read_until_dot(@_);

   213 }

   214 

   215 sub getfh

   216 {

   217  @_ == 2 or croak 'usage: $pop3->getfh( MSGNUM )';

   218  my $me = shift;

   219 

   220  return unless $me->_RETR(shift);

   221  return        $me->tied_fh;

   222 }

   223 

   224 

   225 

   226 sub delete

   227 {

   228  @_ == 2 or croak 'usage: $pop3->delete( MSGNUM )';

   229  $_[0]->_DELE($_[1]);

   230 }

   231 

   232 sub uidl

   233 {

   234  @_ == 1 || @_ == 2 or croak 'usage: $pop3->uidl( [ MSGNUM ] )';

   235  my $me = shift;

   236  my $uidl;

   237 

   238  $me->_UIDL(@_) or

   239     return undef;

   240  if(@_)

   241   {

   242    $uidl = ($me->message =~ /\d+\s+([\041-\176]+)/)[0];

   243   }

   244  else

   245   {

   246    my $ref = $me->read_until_dot

   247 	or return undef;

   248    my $ln;

   249    $uidl = {};

   250    foreach $ln (@$ref) {

   251      my($msg,$uid) = $ln =~ /^\s*(\d+)\s+([\041-\176]+)/;

   252      $uidl->{$msg} = $uid;

   253    }

   254   }

   255  return $uidl;

   256 }

   257 

   258 sub ping

   259 {

   260  @_ == 2 or croak 'usage: $pop3->ping( USER )';

   261  my $me = shift;

   262 

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

   264 

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

   266 }

   267 

   268 sub _lookup_credentials

   269 {

   270   my ($me, $user) = @_;

   271 

   272   require Net::Netrc;

   273 

   274   $user ||= eval { local $SIG{__DIE__}; (getpwuid($>))[0] } ||

   275     $ENV{NAME} || $ENV{USER} || $ENV{LOGNAME};

   276 

   277   my $m = Net::Netrc->lookup(${*$me}{'net_pop3_host'},$user);

   278   $m ||= Net::Netrc->lookup(${*$me}{'net_pop3_host'});

   279 

   280   my $pass = $m ? $m->password || ""

   281                 : "";

   282 

   283   ($user, $pass);

   284 }

   285 

   286 sub _get_mailbox_count

   287 {

   288   my ($me) = @_;

   289   my $ret = ${*$me}{'net_pop3_count'} = ($me->message =~ /(\d+)\s+message/io)

   290 	  ? $1 : ($me->popstat)[0];

   291 

   292   $ret ? $ret : "0E0";

   293 }

   294 

   295 

   296 sub _STAT { shift->command('STAT')->response() == CMD_OK }

   297 sub _LIST { shift->command('LIST',@_)->response() == CMD_OK }

   298 sub _RETR { shift->command('RETR',$_[0])->response() == CMD_OK }

   299 sub _DELE { shift->command('DELE',$_[0])->response() == CMD_OK }

   300 sub _NOOP { shift->command('NOOP')->response() == CMD_OK }

   301 sub _RSET { shift->command('RSET')->response() == CMD_OK }

   302 sub _QUIT { shift->command('QUIT')->response() == CMD_OK }

   303 sub _TOP  { shift->command('TOP', @_)->response() == CMD_OK }

   304 sub _UIDL { shift->command('UIDL',@_)->response() == CMD_OK }

   305 sub _USER { shift->command('USER',$_[0])->response() == CMD_OK }

   306 sub _PASS { shift->command('PASS',$_[0])->response() == CMD_OK }

   307 sub _APOP { shift->command('APOP',@_)->response() == CMD_OK }

   308 sub _PING { shift->command('PING',$_[0])->response() == CMD_OK }

   309 

   310 sub _RPOP { shift->command('RPOP',$_[0])->response() == CMD_OK }

   311 sub _LAST { shift->command('LAST')->response() == CMD_OK }

   312 

   313 sub quit

   314 {

   315  my $me = shift;

   316 

   317  $me->_QUIT;

   318  $me->close;

   319 }

   320 

   321 sub DESTROY

   322 {

   323  my $me = shift;

   324 

   325  if(defined fileno($me))

   326   {

   327    $me->reset;

   328    $me->quit;

   329   }

   330 }

   331 

   332 ##

   333 ## POP3 has weird responses, so we emulate them to look the same :-)

   334 ##

   335 

   336 sub response

   337 {

   338  my $cmd = shift;

   339  my $str = $cmd->getline() || return undef;

   340  my $code = "500";

   341 

   342  $cmd->debug_print(0,$str)

   343    if ($cmd->debug);

   344 

   345  if($str =~ s/^\+OK\s*//io)

   346   {

   347    $code = "200"

   348   }

   349  else

   350   {

   351    $str =~ s/^-ERR\s*//io;

   352   }

   353 

   354  ${*$cmd}{'net_cmd_resp'} = [ $str ];

   355  ${*$cmd}{'net_cmd_code'} = $code;

   356 

   357  substr($code,0,1);

   358 }

   359 

   360 1;

   361 

   362 __END__

   363 

   364 =head1 NAME

   365 

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

   367 

   368 =head1 SYNOPSIS

   369 

   370     use Net::POP3;

   371 

   372     # Constructors

   373     $pop = Net::POP3->new('pop3host');

   374     $pop = Net::POP3->new('pop3host', Timeout => 60);

   375 

   376     if ($pop->login($username, $password) > 0) {

   377       my $msgnums = $pop->list; # hashref of msgnum => size

   378       foreach my $msgnum (keys %$msgnums) {

   379         my $msg = $pop->get($msgnum);

   380         print @$msg;

   381         $pop->delete($msgnum);

   382       }

   383     }

   384 

   385     $pop->quit;

   386 

   387 =head1 DESCRIPTION

   388 

   389 This module implements a client interface to the POP3 protocol, enabling

   390 a perl5 application to talk to POP3 servers. This documentation assumes

   391 that you are familiar with the POP3 protocol described in RFC1939.

   392 

   393 A new Net::POP3 object must be created with the I<new> method. Once

   394 this has been done, all POP3 commands are accessed via method calls

   395 on the object.

   396 

   397 =head1 CONSTRUCTOR

   398 

   399 =over 4

   400 

   401 =item new ( [ HOST, ] [ OPTIONS ] )

   402 

   403 This is the constructor for a new Net::POP3 object. C<HOST> is the

   404 name of the remote host to which a POP3 connection is required.

   405 

   406 If C<HOST> is not given, then the C<POP3_Host> specified in C<Net::Config>

   407 will be used.

   408 

   409 C<OPTIONS> are passed in a hash like fashion, using key and value pairs.

   410 Possible options are:

   411 

   412 B<ResvPort> - If given then the socket for the C<Net::POP3> object

   413 will be bound to the local port given using C<bind> when the socket is

   414 created.

   415 

   416 B<Timeout> - Maximum time, in seconds, to wait for a response from the

   417 POP3 server (default: 120)

   418 

   419 B<Debug> - Enable debugging information

   420 

   421 =back

   422 

   423 =head1 METHODS

   424 

   425 Unless otherwise stated all methods return either a I<true> or I<false>

   426 value, with I<true> meaning that the operation was a success. When a method

   427 states that it returns a value, failure will be returned as I<undef> or an

   428 empty list.

   429 

   430 =over 4

   431 

   432 =item user ( USER )

   433 

   434 Send the USER command.

   435 

   436 =item pass ( PASS )

   437 

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

   439 

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

   441 

   442 Send both the USER and PASS commands. If C<PASS> is not given the

   443 C<Net::POP3> uses C<Net::Netrc> to lookup the password using the host

   444 and username. If the username is not specified then the current user name

   445 will be used.

   446 

   447 Returns the number of messages in the mailbox. However if there are no

   448 messages on the server the string C<"0E0"> will be returned. This is

   449 will give a true value in a boolean context, but zero in a numeric context.

   450 

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

   452 

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

   454 

   455 Authenticate with the server identifying as C<USER> with password C<PASS>.

   456 Similar to L</login>, but the password is not sent in clear text.

   457 

   458 To use this method you must have the Digest::MD5 or the MD5 module installed,

   459 otherwise this method will return I<undef>.

   460 

   461 =item top ( MSGNUM [, NUMLINES ] )

   462 

   463 Get the header and the first C<NUMLINES> of the body for the message

   464 C<MSGNUM>. Returns a reference to an array which contains the lines of text

   465 read from the server.

   466 

   467 =item list ( [ MSGNUM ] )

   468 

   469 If called with an argument the C<list> returns the size of the message

   470 in octets.

   471 

   472 If called without arguments a reference to a hash is returned. The

   473 keys will be the C<MSGNUM>'s of all undeleted messages and the values will

   474 be their size in octets.

   475 

   476 =item get ( MSGNUM [, FH ] )

   477 

   478 Get the message C<MSGNUM> from the remote mailbox. If C<FH> is not given

   479 then get returns a reference to an array which contains the lines of

   480 text read from the server. If C<FH> is given then the lines returned

   481 from the server are printed to the filehandle C<FH>.

   482 

   483 =item getfh ( MSGNUM )

   484 

   485 As per get(), but returns a tied filehandle.  Reading from this

   486 filehandle returns the requested message.  The filehandle will return

   487 EOF at the end of the message and should not be reused.

   488 

   489 =item last ()

   490 

   491 Returns the highest C<MSGNUM> of all the messages accessed.

   492 

   493 =item popstat ()

   494 

   495 Returns a list of two elements. These are the number of undeleted

   496 elements and the size of the mbox in octets.

   497 

   498 =item ping ( USER )

   499 

   500 Returns a list of two elements. These are the number of new messages

   501 and the total number of messages for C<USER>.

   502 

   503 =item uidl ( [ MSGNUM ] )

   504 

   505 Returns a unique identifier for C<MSGNUM> if given. If C<MSGNUM> is not

   506 given C<uidl> returns a reference to a hash where the keys are the

   507 message numbers and the values are the unique identifiers.

   508 

   509 =item delete ( MSGNUM )

   510 

   511 Mark message C<MSGNUM> to be deleted from the remote mailbox. All messages

   512 that are marked to be deleted will be removed from the remote mailbox

   513 when the server connection closed.

   514 

   515 =item reset ()

   516 

   517 Reset the status of the remote POP3 server. This includes reseting the

   518 status of all messages to not be deleted.

   519 

   520 =item quit ()

   521 

   522 Quit and close the connection to the remote POP3 server. Any messages marked

   523 as deleted will be deleted from the remote mailbox.

   524 

   525 =back

   526 

   527 =head1 NOTES

   528 

   529 If a C<Net::POP3> object goes out of scope before C<quit> method is called

   530 then the C<reset> method will called before the connection is closed. This

   531 means that any messages marked to be deleted will not be.

   532 

   533 =head1 SEE ALSO

   534 

   535 L<Net::Netrc>,

   536 L<Net::Cmd>

   537 

   538 =head1 AUTHOR

   539 

   540 Graham Barr <gbarr@pobox.com>

   541 

   542 =head1 COPYRIGHT

   543 

   544 Copyright (c) 1995-1997 Graham Barr. All rights reserved.

   545 This program is free software; you can redistribute it and/or modify

   546 it under the same terms as Perl itself.

   547 

   548 =for html <hr>

   549 

   550 I<$Id: //depot/libnet/Net/POP3.pm#24 $>

   551 

   552 =cut