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.23"; # $Id: //depot/libnet/Net/POP3.pm#22 $
  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 =head1 DESCRIPTION
 377
 378 This module implements a client interface to the POP3 protocol, enabling
 379 a perl5 application to talk to POP3 servers. This documentation assumes
 380 that you are familiar with the POP3 protocol described in RFC1939.
 381
 382 A new Net::POP3 object must be created with the I<new> method. Once
 383 this has been done, all POP3 commands are accessed via method calls
 384 on the object.
 385
 386 =head1 EXAMPLES
 387
 388     Need some small examples in here :-)
 389
 390 =head1 CONSTRUCTOR
 391
 392 =over 4
 393
 394 =item new ( [ HOST, ] [ OPTIONS ] )
 395
 396 This is the constructor for a new Net::POP3 object. C<HOST> is the
 397 name of the remote host to which a POP3 connection is required.
 398
 399 If C<HOST> is not given, then the C<POP3_Host> specified in C<Net::Config>
 400 will be used.
 401
 402 C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
 403 Possible options are:
 404
 405 B<ResvPort> - If given then the socket for the C<Net::POP3> object
 406 will be bound to the local port given using C<bind> when the socket is
 407 created.
 408
 409 B<Timeout> - Maximum time, in seconds, to wait for a response from the
 410 POP3 server (default: 120)
 411
 412 B<Debug> - Enable debugging information
 413
 414 =back
 415
 416 =head1 METHODS
 417
 418 Unless otherwise stated all methods return either a I<true> or I<false>
 419 value, with I<true> meaning that the operation was a success. When a method
 420 states that it returns a value, failure will be returned as I<undef> or an
 421 empty list.
 422
 423 =over 4
 424
 425 =item user ( USER )
 426
 427 Send the USER command.
 428
 429 =item pass ( PASS )
 430
 431 Send the PASS command. Returns the number of messages in the mailbox.
 432
 433 =item login ( [ USER [, PASS ]] )
 434
 435 Send both the USER and PASS commands. If C<PASS> is not given the
 436 C<Net::POP3> uses C<Net::Netrc> to lookup the password using the host
 437 and username. If the username is not specified then the current user name
 438 will be used.
 439
 440 Returns the number of messages in the mailbox. However if there are no
 441 messages on the server the string C<"0E0"> will be returned. This is
 442 will give a true value in a boolean context, but zero in a numeric context.
 443
 444 If there was an error authenticating the user then I<undef> will be returned.
 445
 446 =item apop ( [ USER [, PASS ]] )
 447
 448 Authenticate with the server identifying as C<USER> with password C<PASS>.
 449 Similar to L</login>, but the password is not sent in clear text.
 450
 451 To use this method you must have the Digest::MD5 or the MD5 module installed,
 452 otherwise this method will return I<undef>.
 453
 454 =item top ( MSGNUM [, NUMLINES ] )
 455
 456 Get the header and the first C<NUMLINES> of the body for the message
 457 C<MSGNUM>. Returns a reference to an array which contains the lines of text
 458 read from the server.
 459
 460 =item list ( [ MSGNUM ] )
 461
 462 If called with an argument the C<list> returns the size of the message
 463 in octets.
 464
 465 If called without arguments a reference to a hash is returned. The
 466 keys will be the C<MSGNUM>'s of all undeleted messages and the values will
 467 be their size in octets.
 468
 469 =item get ( MSGNUM [, FH ] )
 470
 471 Get the message C<MSGNUM> from the remote mailbox. If C<FH> is not given
 472 then get returns a reference to an array which contains the lines of
 473 text read from the server. If C<FH> is given then the lines returned
 474 from the server are printed to the filehandle C<FH>.
 475
 476 =item getfh ( MSGNUM )
 477
 478 As per get(), but returns a tied filehandle.  Reading from this
 479 filehandle returns the requested message.  The filehandle will return
 480 EOF at the end of the message and should not be reused.
 481
 482 =item last ()
 483
 484 Returns the highest C<MSGNUM> of all the messages accessed.
 485
 486 =item popstat ()
 487
 488 Returns a list of two elements. These are the number of undeleted
 489 elements and the size of the mbox in octets.
 490
 491 =item ping ( USER )
 492
 493 Returns a list of two elements. These are the number of new messages
 494 and the total number of messages for C<USER>.
 495
 496 =item uidl ( [ MSGNUM ] )
 497
 498 Returns a unique identifier for C<MSGNUM> if given. If C<MSGNUM> is not
 499 given C<uidl> returns a reference to a hash where the keys are the
 500 message numbers and the values are the unique identifiers.
 501
 502 =item delete ( MSGNUM )
 503
 504 Mark message C<MSGNUM> to be deleted from the remote mailbox. All messages
 505 that are marked to be deleted will be removed from the remote mailbox
 506 when the server connection closed.
 507
 508 =item reset ()
 509
 510 Reset the status of the remote POP3 server. This includes reseting the
 511 status of all messages to not be deleted.
 512
 513 =item quit ()
 514
 515 Quit and close the connection to the remote POP3 server. Any messages marked
 516 as deleted will be deleted from the remote mailbox.
 517
 518 =back
 519
 520 =head1 NOTES
 521
 522 If a C<Net::POP3> object goes out of scope before C<quit> method is called
 523 then the C<reset> method will called before the connection is closed. This
 524 means that any messages marked to be deleted will not be.
 525
 526 =head1 SEE ALSO
 527
 528 L<Net::Netrc>,
 529 L<Net::Cmd>
 530
 531 =head1 AUTHOR
 532
 533 Graham Barr <gbarr@pobox.com>
 534
 535 =head1 COPYRIGHT
 536
 537 Copyright (c) 1995-1997 Graham Barr. All rights reserved.
 538 This program is free software; you can redistribute it and/or modify
 539 it under the same terms as Perl itself.
 540
 541 =for html <hr>
 542
 543 I<$Id: //depot/libnet/Net/POP3.pm#22 $>
 544
 545 =cut