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 = 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