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