lib/Net/POP3.pm

   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;
  25  $host = shift if @_ % 2;
  26  my %arg  = @_;
  27  my $hosts = defined $host ? [ $host ] : $NetConfig{pop3_hosts};
  28  my $obj;
  29  my @localport = exists $arg{ResvPort} ? ( LocalPort => $arg{ResvPort} ): ();
  30
  31  my $h;
  32  foreach $h (@{$hosts})
  33   {
  34    $obj = $type->SUPER::new(PeerAddr => ($host = $h),
  35                             PeerPort => $arg{Port} || 'pop3(110)',
  36                             Proto    => 'tcp',
  37                             @localport,
  38                             Timeout  => defined $arg{Timeout}
  39                                                 ? $arg{Timeout}
  40                                                 : 120
  41                            ) and last;
  42   }
  43
  44  return undef
  45         unless defined $obj;
  46
  47  ${*$obj}{'net_pop3_host'} = $host;
  48
  49  $obj->autoflush(1);
  50  $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef);
  51
  52  unless ($obj->response() == CMD_OK)
  53   {
  54    $obj->close();
  55    return undef;
  56   }
  57
  58  ${*$obj}{'net_pop3_banner'} = $obj->message;
  59
  60  $obj;
  61 }
  62
  63 ##
  64 ## We don't want people sending me their passwords when they report problems
  65 ## now do we :-)
  66 ##
  67
  68 sub debug_text { $_[2] =~ /^(pass|rpop)/i ? "$1 ....\n" : $_[2]; }
  69
  70 sub login
  71 {
  72  @_ >= 1 && @_ <= 3 or croak 'usage: $pop3->login( USER, PASS )';
  73  my($me,$user,$pass) = @_;
  74
  75  if (@_ <= 2) {
  76    ($user, $pass) = $me->_lookup_credentials($user);
  77  }
  78
  79  $me->user($user) and
  80     $me->pass($pass);
  81 }
  82
  83 sub apop
  84 {
  85  @_ >= 1 && @_ <= 3 or croak 'usage: $pop3->apop( USER, PASS )';
  86  my($me,$user,$pass) = @_;
  87  my $banner;
  88  my $md;
  89
  90  if (eval { local $SIG{__DIE__}; require Digest::MD5 }) {
  91    $md = Digest::MD5->new();
  92  } elsif (eval { local $SIG{__DIE__}; require MD5 }) {
  93    $md = MD5->new();
  94  } else {
  95    carp "You need to install Digest::MD5 or MD5 to use the APOP command";
  96    return undef;
  97  }
  98
  99  return undef
 100    unless ( $banner = (${*$me}{'net_pop3_banner'} =~ /(<.*>)/)[0] );
 101
 102  if (@_ <= 2) {
 103    ($user, $pass) = $me->_lookup_credentials($user);
 104  }
 105
 106  $md->add($banner,$pass);
 107
 108  return undef
 109     unless($me->_APOP($user,$md->hexdigest));
 110
 111  $me->_get_mailbox_count();
 112 }
 113
 114 sub user
 115 {
 116  @_ == 2 or croak 'usage: $pop3->user( USER )';
 117  $_[0]->_USER($_[1]) ? 1 : undef;
 118 }
 119
 120 sub pass
 121 {
 122  @_ == 2 or croak 'usage: $pop3->pass( PASS )';
 123
 124  my($me,$pass) = @_;
 125
 126  return undef
 127    unless($me->_PASS($pass));
 128
 129  $me->_get_mailbox_count();
 130 }
 131
 132 sub reset
 133 {
 134  @_ == 1 or croak 'usage: $obj->reset()';
 135
 136  my $me = shift;
 137
 138  return 0
 139    unless($me->_RSET);
 140
 141  if(defined ${*$me}{'net_pop3_mail'})
 142   {
 143    local $_;
 144    foreach (@{${*$me}{'net_pop3_mail'}})
 145     {
 146      delete $_->{'net_pop3_deleted'};
 147     }
 148   }
 149 }
 150
 151 sub last
 152 {
 153  @_ == 1 or croak 'usage: $obj->last()';
 154
 155  return undef
 156     unless $_[0]->_LAST && $_[0]->message =~ /(\d+)/;
 157
 158  return $1;
 159 }
 160
 161 sub top
 162 {
 163  @_ == 2 || @_ == 3 or croak 'usage: $pop3->top( MSGNUM [, NUMLINES ])';
 164  my $me = shift;
 165
 166  return undef
 167     unless $me->_TOP($_[0], $_[1] || 0);
 168
 169  $me->read_until_dot;
 170 }
 171
 172 sub popstat
 173 {
 174  @_ == 1 or croak 'usage: $pop3->popstat()';
 175  my $me = shift;
 176
 177  return ()
 178     unless $me->_STAT && $me->message =~ /(\d+)\D+(\d+)/;
 179
 180  ($1 || 0, $2 || 0);
 181 }
 182
 183 sub list
 184 {
 185  @_ == 1 || @_ == 2 or croak 'usage: $pop3->list( [ MSGNUM ] )';
 186  my $me = shift;
 187
 188  return undef
 189     unless $me->_LIST(@_);
 190
 191  if(@_)
 192   {
 193    $me->message =~ /\d+\D+(\d+)/;
 194    return $1 || undef;
 195   }
 196
 197  my $info = $me->read_until_dot
 198         or return undef;
 199
 200  my %hash = map { (/(\d+)\D+(\d+)/) } @$info;
 201
 202  return \%hash;
 203 }
 204
 205 sub get
 206 {
 207  @_ == 2 or @_ == 3 or croak 'usage: $pop3->get( MSGNUM [, FH ])';
 208  my $me = shift;
 209
 210  return undef
 211     unless $me->_RETR(shift);
 212
 213  $me->read_until_dot(@_);
 214 }
 215
 216 sub getfh
 217 {
 218  @_ == 2 or croak 'usage: $pop3->getfh( MSGNUM )';
 219  my $me = shift;
 220
 221  return unless $me->_RETR(shift);
 222  return        $me->tied_fh;
 223 }
 224
 225
 226
 227 sub delete
 228 {
 229  @_ == 2 or croak 'usage: $pop3->delete( MSGNUM )';
 230  $_[0]->_DELE($_[1]);
 231 }
 232
 233 sub uidl
 234 {
 235  @_ == 1 || @_ == 2 or croak 'usage: $pop3->uidl( [ MSGNUM ] )';
 236  my $me = shift;
 237  my $uidl;
 238
 239  $me->_UIDL(@_) or
 240     return undef;
 241  if(@_)
 242   {
 243    $uidl = ($me->message =~ /\d+\s+([\041-\176]+)/)[0];
 244   }
 245  else
 246   {
 247    my $ref = $me->read_until_dot
 248         or return undef;
 249    my $ln;
 250    $uidl = {};
 251    foreach $ln (@$ref) {
 252      my($msg,$uid) = $ln =~ /^\s*(\d+)\s+([\041-\176]+)/;
 253      $uidl->{$msg} = $uid;
 254    }
 255   }
 256  return $uidl;
 257 }
 258
 259 sub ping
 260 {
 261  @_ == 2 or croak 'usage: $pop3->ping( USER )';
 262  my $me = shift;
 263
 264  return () unless $me->_PING(@_) && $me->message =~ /(\d+)\D+(\d+)/;
 265
 266  ($1 || 0, $2 || 0);
 267 }
 268
 269 sub _lookup_credentials
 270 {
 271   my ($me, $user) = @_;
 272
 273   require Net::Netrc;
 274
 275   $user ||= eval { local $SIG{__DIE__}; (getpwuid($>))[0] } ||
 276     $ENV{NAME} || $ENV{USER} || $ENV{LOGNAME};
 277
 278   my $m = Net::Netrc->lookup(${*$me}{'net_pop3_host'},$user);
 279   $m ||= Net::Netrc->lookup(${*$me}{'net_pop3_host'});
 280
 281   my $pass = $m ? $m->password || ""
 282                 : "";
 283
 284   ($user, $pass);
 285 }
 286
 287 sub _get_mailbox_count
 288 {
 289   my ($me) = @_;
 290   my $ret = ${*$me}{'net_pop3_count'} = ($me->message =~ /(\d+)\s+message/io)
 291           ? $1 : ($me->popstat)[0];
 292
 293   $ret ? $ret : "0E0";
 294 }
 295
 296
 297 sub _STAT { shift->command('STAT')->response() == CMD_OK }
 298 sub _LIST { shift->command('LIST',@_)->response() == CMD_OK }
 299 sub _RETR { shift->command('RETR',$_[0])->response() == CMD_OK }
 300 sub _DELE { shift->command('DELE',$_[0])->response() == CMD_OK }
 301 sub _NOOP { shift->command('NOOP')->response() == CMD_OK }
 302 sub _RSET { shift->command('RSET')->response() == CMD_OK }
 303 sub _QUIT { shift->command('QUIT')->response() == CMD_OK }
 304 sub _TOP  { shift->command('TOP', @_)->response() == CMD_OK }
 305 sub _UIDL { shift->command('UIDL',@_)->response() == CMD_OK }
 306 sub _USER { shift->command('USER',$_[0])->response() == CMD_OK }
 307 sub _PASS { shift->command('PASS',$_[0])->response() == CMD_OK }
 308 sub _APOP { shift->command('APOP',@_)->response() == CMD_OK }
 309 sub _PING { shift->command('PING',$_[0])->response() == CMD_OK }
 310
 311 sub _RPOP { shift->command('RPOP',$_[0])->response() == CMD_OK }
 312 sub _LAST { shift->command('LAST')->response() == CMD_OK }
 313
 314 sub quit
 315 {
 316  my $me = shift;
 317
 318  $me->_QUIT;
 319  $me->close;
 320 }
 321
 322 sub DESTROY
 323 {
 324  my $me = shift;
 325
 326  if(defined fileno($me))
 327   {
 328    $me->reset;
 329    $me->quit;
 330   }
 331 }
 332
 333 ##
 334 ## POP3 has weird responses, so we emulate them to look the same :-)
 335 ##
 336
 337 sub response
 338 {
 339  my $cmd = shift;
 340  my $str = $cmd->getline() || return undef;
 341  my $code = "500";
 342
 343  $cmd->debug_print(0,$str)
 344    if ($cmd->debug);
 345
 346  if($str =~ s/^\+OK\s*//io)
 347   {
 348    $code = "200"
 349   }
 350  else
 351   {
 352    $str =~ s/^-ERR\s*//io;
 353   }
 354
 355  ${*$cmd}{'net_cmd_resp'} = [ $str ];
 356  ${*$cmd}{'net_cmd_code'} = $code;
 357
 358  substr($code,0,1);
 359 }
 360
 361 1;
 362
 363 __END__
 364
 365 =head1 NAME
 366
 367 Net::POP3 - Post Office Protocol 3 Client class (RFC1939)
 368
 369 =head1 SYNOPSIS
 370
 371     use Net::POP3;
 372
 373     # Constructors
 374     $pop = Net::POP3->new('pop3host');
 375     $pop = Net::POP3->new('pop3host', Timeout => 60);
 376
 377     if ($pop->login($username, $password) > 0) {
 378       my $msgnums = $pop->list; # hashref of msgnum => size
 379       foreach my $msgnum (keys %$msgnums) {
 380         my $msg = $pop->get($msgnum);
 381         print @$msg;
 382         $pop->delete($msgnum);
 383       }
 384     }
 385
 386     $pop->quit;
 387
 388 =head1 DESCRIPTION
 389
 390 This module implements a client interface to the POP3 protocol, enabling
 391 a perl5 application to talk to POP3 servers. This documentation assumes
 392 that you are familiar with the POP3 protocol described in RFC1939.
 393
 394 A new Net::POP3 object must be created with the I<new> method. Once
 395 this has been done, all POP3 commands are accessed via method calls
 396 on the object.
 397
 398 =head1 CONSTRUCTOR
 399
 400 =over 4
 401
 402 =item new ( [ HOST, ] [ OPTIONS ] )
 403
 404 This is the constructor for a new Net::POP3 object. C<HOST> is the
 405 name of the remote host to which a POP3 connection is required.
 406
 407 If C<HOST> is not given, then the C<POP3_Host> specified in C<Net::Config>
 408 will be used.
 409
 410 C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
 411 Possible options are:
 412
 413 B<ResvPort> - If given then the socket for the C<Net::POP3> object
 414 will be bound to the local port given using C<bind> when the socket is
 415 created.
 416
 417 B<Timeout> - Maximum time, in seconds, to wait for a response from the
 418 POP3 server (default: 120)
 419
 420 B<Debug> - Enable debugging information
 421
 422 =back
 423
 424 =head1 METHODS
 425
 426 Unless otherwise stated all methods return either a I<true> or I<false>
 427 value, with I<true> meaning that the operation was a success. When a method
 428 states that it returns a value, failure will be returned as I<undef> or an
 429 empty list.
 430
 431 =over 4
 432
 433 =item user ( USER )
 434
 435 Send the USER command.
 436
 437 =item pass ( PASS )
 438
 439 Send the PASS command. Returns the number of messages in the mailbox.
 440
 441 =item login ( [ USER [, PASS ]] )
 442
 443 Send both the USER and PASS commands. If C<PASS> is not given the
 444 C<Net::POP3> uses C<Net::Netrc> to lookup the password using the host
 445 and username. If the username is not specified then the current user name
 446 will be used.
 447
 448 Returns the number of messages in the mailbox. However if there are no
 449 messages on the server the string C<"0E0"> will be returned. This is
 450 will give a true value in a boolean context, but zero in a numeric context.
 451
 452 If there was an error authenticating the user then I<undef> will be returned.
 453
 454 =item apop ( [ USER [, PASS ]] )
 455
 456 Authenticate with the server identifying as C<USER> with password C<PASS>.
 457 Similar to L</login>, but the password is not sent in clear text.
 458
 459 To use this method you must have the Digest::MD5 or the MD5 module installed,
 460 otherwise this method will return I<undef>.
 461
 462 =item top ( MSGNUM [, NUMLINES ] )
 463
 464 Get the header and the first C<NUMLINES> of the body for the message
 465 C<MSGNUM>. Returns a reference to an array which contains the lines of text
 466 read from the server.
 467
 468 =item list ( [ MSGNUM ] )
 469
 470 If called with an argument the C<list> returns the size of the message
 471 in octets.
 472
 473 If called without arguments a reference to a hash is returned. The
 474 keys will be the C<MSGNUM>'s of all undeleted messages and the values will
 475 be their size in octets.
 476
 477 =item get ( MSGNUM [, FH ] )
 478
 479 Get the message C<MSGNUM> from the remote mailbox. If C<FH> is not given
 480 then get returns a reference to an array which contains the lines of
 481 text read from the server. If C<FH> is given then the lines returned
 482 from the server are printed to the filehandle C<FH>.
 483
 484 =item getfh ( MSGNUM )
 485
 486 As per get(), but returns a tied filehandle.  Reading from this
 487 filehandle returns the requested message.  The filehandle will return
 488 EOF at the end of the message and should not be reused.
 489
 490 =item last ()
 491
 492 Returns the highest C<MSGNUM> of all the messages accessed.
 493
 494 =item popstat ()
 495
 496 Returns a list of two elements. These are the number of undeleted
 497 elements and the size of the mbox in octets.
 498
 499 =item ping ( USER )
 500
 501 Returns a list of two elements. These are the number of new messages
 502 and the total number of messages for C<USER>.
 503
 504 =item uidl ( [ MSGNUM ] )
 505
 506 Returns a unique identifier for C<MSGNUM> if given. If C<MSGNUM> is not
 507 given C<uidl> returns a reference to a hash where the keys are the
 508 message numbers and the values are the unique identifiers.
 509
 510 =item delete ( MSGNUM )
 511
 512 Mark message C<MSGNUM> to be deleted from the remote mailbox. All messages
 513 that are marked to be deleted will be removed from the remote mailbox
 514 when the server connection closed.
 515
 516 =item reset ()
 517
 518 Reset the status of the remote POP3 server. This includes reseting the
 519 status of all messages to not be deleted.
 520
 521 =item quit ()
 522
 523 Quit and close the connection to the remote POP3 server. Any messages marked
 524 as deleted will be deleted from the remote mailbox.
 525
 526 =back
 527
 528 =head1 NOTES
 529
 530 If a C<Net::POP3> object goes out of scope before C<quit> method is called
 531 then the C<reset> method will called before the connection is closed. This
 532 means that any messages marked to be deleted will not be.
 533
 534 =head1 SEE ALSO
 535
 536 L<Net::Netrc>,
 537 L<Net::Cmd>
 538
 539 =head1 AUTHOR
 540
 541 Graham Barr <gbarr@pobox.com>
 542
 543 =head1 COPYRIGHT
 544
 545 Copyright (c) 1995-1997 Graham Barr. All rights reserved.
 546 This program is free software; you can redistribute it and/or modify
 547 it under the same terms as Perl itself.
 548
 549 =for html <hr>
 550
 551 I<$Id: //depot/libnet/Net/POP3.pm#24 $>
 552
 553 =cut