lib/Net/POP3.pm

   1 # Net::POP3.pm
   2 #
   3 # Copyright (c) 1995-2004 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.28_2";
  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,%arg);
  25  if (@_ % 2) {
  26    $host = shift ;
  27    %arg  = @_;
  28  } else {
  29    %arg = @_;
  30    $host=delete $arg{Host};
  31  }
  32  my $hosts = defined $host ? [ $host ] : $NetConfig{pop3_hosts};
  33  my $obj;
  34  my @localport = exists $arg{ResvPort} ? ( LocalPort => $arg{ResvPort} ): ();
  35
  36  my $h;
  37  foreach $h (@{$hosts})
  38   {
  39    $obj = $type->SUPER::new(PeerAddr => ($host = $h),
  40                             PeerPort => $arg{Port} || 'pop3(110)',
  41                             Proto    => 'tcp',
  42                             @localport,
  43                             Timeout  => defined $arg{Timeout}
  44                                                 ? $arg{Timeout}
  45                                                 : 120
  46                            ) and last;
  47   }
  48
  49  return undef
  50         unless defined $obj;
  51
  52  ${*$obj}{'net_pop3_host'} = $host;
  53
  54  $obj->autoflush(1);
  55  $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef);
  56
  57  unless ($obj->response() == CMD_OK)
  58   {
  59    $obj->close();
  60    return undef;
  61   }
  62
  63  ${*$obj}{'net_pop3_banner'} = $obj->message;
  64
  65  $obj;
  66 }
  67
  68 sub host {
  69  my $me = shift;
  70  ${*$me}{'net_pop3_host'};
  71 }
  72
  73 ##
  74 ## We don't want people sending me their passwords when they report problems
  75 ## now do we :-)
  76 ##
  77
  78 sub debug_text { $_[2] =~ /^(pass|rpop)/i ? "$1 ....\n" : $_[2]; }
  79
  80 sub login
  81 {
  82  @_ >= 1 && @_ <= 3 or croak 'usage: $pop3->login( USER, PASS )';
  83  my($me,$user,$pass) = @_;
  84
  85  if (@_ <= 2) {
  86    ($user, $pass) = $me->_lookup_credentials($user);
  87  }
  88
  89  $me->user($user) and
  90     $me->pass($pass);
  91 }
  92
  93 sub apop
  94 {
  95  @_ >= 1 && @_ <= 3 or croak 'usage: $pop3->apop( USER, PASS )';
  96  my($me,$user,$pass) = @_;
  97  my $banner;
  98  my $md;
  99
 100  if (eval { local $SIG{__DIE__}; require Digest::MD5 }) {
 101    $md = Digest::MD5->new();
 102  } elsif (eval { local $SIG{__DIE__}; require MD5 }) {
 103    $md = MD5->new();
 104  } else {
 105    carp "You need to install Digest::MD5 or MD5 to use the APOP command";
 106    return undef;
 107  }
 108
 109  return undef
 110    unless ( $banner = (${*$me}{'net_pop3_banner'} =~ /(<.*>)/)[0] );
 111
 112  if (@_ <= 2) {
 113    ($user, $pass) = $me->_lookup_credentials($user);
 114  }
 115
 116  $md->add($banner,$pass);
 117
 118  return undef
 119     unless($me->_APOP($user,$md->hexdigest));
 120
 121  $me->_get_mailbox_count();
 122 }
 123
 124 sub user
 125 {
 126  @_ == 2 or croak 'usage: $pop3->user( USER )';
 127  $_[0]->_USER($_[1]) ? 1 : undef;
 128 }
 129
 130 sub pass
 131 {
 132  @_ == 2 or croak 'usage: $pop3->pass( PASS )';
 133
 134  my($me,$pass) = @_;
 135
 136  return undef
 137    unless($me->_PASS($pass));
 138
 139  $me->_get_mailbox_count();
 140 }
 141
 142 sub reset
 143 {
 144  @_ == 1 or croak 'usage: $obj->reset()';
 145
 146  my $me = shift;
 147
 148  return 0
 149    unless($me->_RSET);
 150
 151  if(defined ${*$me}{'net_pop3_mail'})
 152   {
 153    local $_;
 154    foreach (@{${*$me}{'net_pop3_mail'}})
 155     {
 156      delete $_->{'net_pop3_deleted'};
 157     }
 158   }
 159 }
 160
 161 sub last
 162 {
 163  @_ == 1 or croak 'usage: $obj->last()';
 164
 165  return undef
 166     unless $_[0]->_LAST && $_[0]->message =~ /(\d+)/;
 167
 168  return $1;
 169 }
 170
 171 sub top
 172 {
 173  @_ == 2 || @_ == 3 or croak 'usage: $pop3->top( MSGNUM [, NUMLINES ])';
 174  my $me = shift;
 175
 176  return undef
 177     unless $me->_TOP($_[0], $_[1] || 0);
 178
 179  $me->read_until_dot;
 180 }
 181
 182 sub popstat
 183 {
 184  @_ == 1 or croak 'usage: $pop3->popstat()';
 185  my $me = shift;
 186
 187  return ()
 188     unless $me->_STAT && $me->message =~ /(\d+)\D+(\d+)/;
 189
 190  ($1 || 0, $2 || 0);
 191 }
 192
 193 sub list
 194 {
 195  @_ == 1 || @_ == 2 or croak 'usage: $pop3->list( [ MSGNUM ] )';
 196  my $me = shift;
 197
 198  return undef
 199     unless $me->_LIST(@_);
 200
 201  if(@_)
 202   {
 203    $me->message =~ /\d+\D+(\d+)/;
 204    return $1 || undef;
 205   }
 206
 207  my $info = $me->read_until_dot
 208         or return undef;
 209
 210  my %hash = map { (/(\d+)\D+(\d+)/) } @$info;
 211
 212  return \%hash;
 213 }
 214
 215 sub get
 216 {
 217  @_ == 2 or @_ == 3 or croak 'usage: $pop3->get( MSGNUM [, FH ])';
 218  my $me = shift;
 219
 220  return undef
 221     unless $me->_RETR(shift);
 222
 223  $me->read_until_dot(@_);
 224 }
 225
 226 sub getfh
 227 {
 228  @_ == 2 or croak 'usage: $pop3->getfh( MSGNUM )';
 229  my $me = shift;
 230
 231  return unless $me->_RETR(shift);
 232  return        $me->tied_fh;
 233 }
 234
 235
 236
 237 sub delete
 238 {
 239  @_ == 2 or croak 'usage: $pop3->delete( MSGNUM )';
 240  my $me = shift;
 241  return  0 unless $me->_DELE(@_);
 242  ${*$me}{'net_pop3_deleted'} = 1;
 243 }
 244
 245 sub uidl
 246 {
 247  @_ == 1 || @_ == 2 or croak 'usage: $pop3->uidl( [ MSGNUM ] )';
 248  my $me = shift;
 249  my $uidl;
 250
 251  $me->_UIDL(@_) or
 252     return undef;
 253  if(@_)
 254   {
 255    $uidl = ($me->message =~ /\d+\s+([\041-\176]+)/)[0];
 256   }
 257  else
 258   {
 259    my $ref = $me->read_until_dot
 260         or return undef;
 261    my $ln;
 262    $uidl = {};
 263    foreach $ln (@$ref) {
 264      my($msg,$uid) = $ln =~ /^\s*(\d+)\s+([\041-\176]+)/;
 265      $uidl->{$msg} = $uid;
 266    }
 267   }
 268  return $uidl;
 269 }
 270
 271 sub ping
 272 {
 273  @_ == 2 or croak 'usage: $pop3->ping( USER )';
 274  my $me = shift;
 275
 276  return () unless $me->_PING(@_) && $me->message =~ /(\d+)\D+(\d+)/;
 277
 278  ($1 || 0, $2 || 0);
 279 }
 280
 281 sub _lookup_credentials
 282 {
 283   my ($me, $user) = @_;
 284
 285   require Net::Netrc;
 286
 287   $user ||= eval { local $SIG{__DIE__}; (getpwuid($>))[0] } ||
 288     $ENV{NAME} || $ENV{USER} || $ENV{LOGNAME};
 289
 290   my $m = Net::Netrc->lookup(${*$me}{'net_pop3_host'},$user);
 291   $m ||= Net::Netrc->lookup(${*$me}{'net_pop3_host'});
 292
 293   my $pass = $m ? $m->password || ""
 294                 : "";
 295
 296   ($user, $pass);
 297 }
 298
 299 sub _get_mailbox_count
 300 {
 301   my ($me) = @_;
 302   my $ret = ${*$me}{'net_pop3_count'} = ($me->message =~ /(\d+)\s+message/io)
 303           ? $1 : ($me->popstat)[0];
 304
 305   $ret ? $ret : "0E0";
 306 }
 307
 308
 309 sub _STAT { shift->command('STAT')->response() == CMD_OK }
 310 sub _LIST { shift->command('LIST',@_)->response() == CMD_OK }
 311 sub _RETR { shift->command('RETR',$_[0])->response() == CMD_OK }
 312 sub _DELE { shift->command('DELE',$_[0])->response() == CMD_OK }
 313 sub _NOOP { shift->command('NOOP')->response() == CMD_OK }
 314 sub _RSET { shift->command('RSET')->response() == CMD_OK }
 315 sub _QUIT { shift->command('QUIT')->response() == CMD_OK }
 316 sub _TOP  { shift->command('TOP', @_)->response() == CMD_OK }
 317 sub _UIDL { shift->command('UIDL',@_)->response() == CMD_OK }
 318 sub _USER { shift->command('USER',$_[0])->response() == CMD_OK }
 319 sub _PASS { shift->command('PASS',$_[0])->response() == CMD_OK }
 320 sub _APOP { shift->command('APOP',@_)->response() == CMD_OK }
 321 sub _PING { shift->command('PING',$_[0])->response() == CMD_OK }
 322
 323 sub _RPOP { shift->command('RPOP',$_[0])->response() == CMD_OK }
 324 sub _LAST { shift->command('LAST')->response() == CMD_OK }
 325
 326 sub _CAPA { shift->command('CAPA')->response() == CMD_OK }
 327
 328 sub quit
 329 {
 330  my $me = shift;
 331
 332  $me->_QUIT;
 333  $me->close;
 334 }
 335
 336 sub DESTROY
 337 {
 338  my $me = shift;
 339
 340  if(defined fileno($me) and ${*$me}{'net_pop3_deleted'})
 341   {
 342    $me->reset;
 343    $me->quit;
 344   }
 345 }
 346
 347 ##
 348 ## POP3 has weird responses, so we emulate them to look the same :-)
 349 ##
 350
 351 sub response {
 352   my $cmd  = shift;
 353   my $str  = $cmd->getline() or return undef;
 354   my $code = "500";
 355
 356   $cmd->debug_print(0, $str)
 357     if ($cmd->debug);
 358
 359   if ($str =~ s/^\+OK\s*//io) {
 360     $code = "200";
 361   }
 362   elsif ($str =~ s/^\+\s*//io) {
 363     $code = "300";
 364   }
 365   else {
 366     $str =~ s/^-ERR\s*//io;
 367   }
 368
 369   ${*$cmd}{'net_cmd_resp'} = [$str];
 370   ${*$cmd}{'net_cmd_code'} = $code;
 371
 372   substr($code, 0, 1);
 373 }
 374
 375
 376 sub capa {
 377     my $this = shift;
 378     my ($capa, %capabilities);
 379
 380     # Fake a capability here
 381     $capabilities{APOP} = '' if ($this->banner() =~ /<.*>/);
 382
 383     if ($this->_CAPA()) {
 384       $capabilities{CAPA} = 1;
 385       $capa = $this->read_until_dot();
 386       %capabilities = (%capabilities, map { /^\s*(\S+)\s*(.*)/ } @$capa);
 387     }
 388     else {
 389       # Check AUTH for SASL capabilities
 390       if ( $this->command('AUTH')->response() == CMD_OK ) {
 391           my $mechanism = $this->read_until_dot();
 392           $capabilities{SASL} = join " ", map { m/([A-Z0-9_-]+)/ } @{ $mechanism };
 393       }
 394     }
 395
 396     return ${*$this}{'net_pop3e_capabilities'} = \%capabilities;
 397 }
 398
 399 sub capabilities {
 400     my $this = shift;
 401
 402     ${*$this}{'net_pop3e_capabilities'} || $this->capa;
 403 }
 404
 405 sub auth {
 406     my ($self, $username, $password) = @_;
 407
 408     eval {
 409         require MIME::Base64;
 410         require Authen::SASL;
 411     } or $self->set_status(500,["Need MIME::Base64 and Authen::SASL todo auth"]), return 0;
 412
 413     my $capa = $self->capa;
 414     my $mechanisms = $capa->{SASL} || 'CRAM-MD5';
 415
 416     my $sasl;
 417
 418     if (ref($username) and UNIVERSAL::isa($username,'Authen::SASL')) {
 419       $sasl = $username;
 420       my $user_mech = $sasl->mechanism || '';
 421       my @user_mech = split(/\s+/, $user_mech);
 422       my %user_mech; @user_mech{@user_mech} = ();
 423
 424       my @server_mech = split(/\s+/,$mechanisms);
 425       my @mech = @user_mech
 426                                 ? grep { exists $user_mech{$_} } @server_mech
 427                                 : @server_mech;
 428       unless (@mech) {
 429         $self->set_status(500,
 430                              [ 'Client SASL mechanisms (',
 431                                join(', ', @user_mech),
 432                                ') do not match the SASL mechnism the server announces (',
 433                                join(', ', @server_mech), ')',
 434                              ]);
 435         return 0;
 436       }
 437
 438       $sasl->mechanism(join(" ",@mech));
 439     }
 440     else {
 441       die "auth(username, password)" if not length $username;
 442       $sasl = Authen::SASL->new(mechanism=> $mechanisms,
 443                                 callback => { user => $username,
 444                                               pass => $password,
 445                                               authname => $username,
 446                                             });
 447     }
 448
 449     # We should probably allow the user to pass the host, but I don't
 450     # currently know and SASL mechanisms that are used by smtp that need it
 451     my ( $hostname ) = split /:/ , ${*$self}{'net_pop3_host'};
 452     my $client = eval { $sasl->client_new('pop',$hostname,0) };
 453
 454     unless ($client) {
 455       my $mech = $sasl->mechanism;
 456       $self->set_status(500, [
 457          " Authen::SASL failure: $@",
 458          '(please check if your local Authen::SASL installation',
 459          "supports mechanism '$mech'"
 460        ]);
 461       return 0;
 462     }
 463
 464     my ($token) = $client->client_start
 465       or do {
 466         my $mech = $client->mechanism;
 467         $self->set_status(500, [
 468           ' Authen::SASL failure:  $client->client_start ',
 469           "mechanism '$mech' hostname #$hostname#",
 470           $client->error
 471         ]);
 472         return 0;
 473       };
 474
 475     # We dont support sasl mechanisms that encrypt the socket traffic.
 476     # todo that we would really need to change the ISA hierarchy
 477     # so we dont inherit from IO::Socket, but instead hold it in an attribute
 478
 479     my @cmd = ("AUTH", $client->mechanism);
 480     my $code;
 481
 482     push @cmd, MIME::Base64::encode_base64($token,'')
 483       if defined $token and length $token;
 484
 485     while (($code = $self->command(@cmd)->response()) == CMD_MORE) {
 486
 487       my ( $token ) = $client->client_step(
 488         MIME::Base64::decode_base64(
 489           ($self->message)[0]
 490         )
 491       ) or do {
 492         $self->set_status(500, [
 493           ' Authen::SASL failure:  $client->client_step ',
 494           "mechanism '", $client->mechanism ," hostname #$hostname#, ",
 495           $client->error
 496         ]);
 497         return 0;
 498       };
 499
 500       @cmd = (MIME::Base64::encode_base64(
 501                   defined $token ?  $token : '',
 502                   ''
 503              )
 504       );
 505     }
 506
 507     $code == CMD_OK;
 508 }
 509
 510 sub banner {
 511     my $this = shift;
 512
 513     return ${*$this}{'net_pop3_banner'};
 514 }
 515
 516 1;
 517
 518 __END__
 519
 520 =head1 NAME
 521
 522 Net::POP3 - Post Office Protocol 3 Client class (RFC1939)
 523
 524 =head1 SYNOPSIS
 525
 526     use Net::POP3;
 527
 528     # Constructors
 529     $pop = Net::POP3->new('pop3host');
 530     $pop = Net::POP3->new('pop3host', Timeout => 60);
 531
 532     if ($pop->login($username, $password) > 0) {
 533       my $msgnums = $pop->list; # hashref of msgnum => size
 534       foreach my $msgnum (keys %$msgnums) {
 535         my $msg = $pop->get($msgnum);
 536         print @$msg;
 537         $pop->delete($msgnum);
 538       }
 539     }
 540
 541     $pop->quit;
 542
 543 =head1 DESCRIPTION
 544
 545 This module implements a client interface to the POP3 protocol, enabling
 546 a perl5 application to talk to POP3 servers. This documentation assumes
 547 that you are familiar with the POP3 protocol described in RFC1939.
 548
 549 A new Net::POP3 object must be created with the I<new> method. Once
 550 this has been done, all POP3 commands are accessed via method calls
 551 on the object.
 552
 553 =head1 CONSTRUCTOR
 554
 555 =over 4
 556
 557 =item new ( [ HOST ] [, OPTIONS ] 0
 558
 559 This is the constructor for a new Net::POP3 object. C<HOST> is the
 560 name of the remote host to which an POP3 connection is required.
 561
 562 C<HOST> is optional. If C<HOST> is not given then it may instead be
 563 passed as the C<Host> option described below. If neither is given then
 564 the C<POP3_Hosts> specified in C<Net::Config> will be used.
 565
 566 C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
 567 Possible options are:
 568
 569 B<Host> - POP3 host to connect to. It may be a single scalar, as defined for
 570 the C<PeerAddr> option in L<IO::Socket::INET>, or a reference to
 571 an array with hosts to try in turn. The L</host> method will return the value
 572 which was used to connect to the host.
 573
 574 B<ResvPort> - If given then the socket for the C<Net::POP3> object
 575 will be bound to the local port given using C<bind> when the socket is
 576 created.
 577
 578 B<Timeout> - Maximum time, in seconds, to wait for a response from the
 579 POP3 server (default: 120)
 580
 581 B<Debug> - Enable debugging information
 582
 583 =back
 584
 585 =head1 METHODS
 586
 587 Unless otherwise stated all methods return either a I<true> or I<false>
 588 value, with I<true> meaning that the operation was a success. When a method
 589 states that it returns a value, failure will be returned as I<undef> or an
 590 empty list.
 591
 592 =over 4
 593
 594 =item auth ( USERNAME, PASSWORD )
 595
 596 Attempt SASL authentication.
 597
 598 =item user ( USER )
 599
 600 Send the USER command.
 601
 602 =item pass ( PASS )
 603
 604 Send the PASS command. Returns the number of messages in the mailbox.
 605
 606 =item login ( [ USER [, PASS ]] )
 607
 608 Send both the USER and PASS commands. If C<PASS> is not given the
 609 C<Net::POP3> uses C<Net::Netrc> to lookup the password using the host
 610 and username. If the username is not specified then the current user name
 611 will be used.
 612
 613 Returns the number of messages in the mailbox. However if there are no
 614 messages on the server the string C<"0E0"> will be returned. This is
 615 will give a true value in a boolean context, but zero in a numeric context.
 616
 617 If there was an error authenticating the user then I<undef> will be returned.
 618
 619 =item apop ( [ USER [, PASS ]] )
 620
 621 Authenticate with the server identifying as C<USER> with password C<PASS>.
 622 Similar to L</login>, but the password is not sent in clear text.
 623
 624 To use this method you must have the Digest::MD5 or the MD5 module installed,
 625 otherwise this method will return I<undef>.
 626
 627 =item banner ()
 628
 629 Return the sever's connection banner
 630
 631 =item capa ()
 632
 633 Return a reference to a hash of the capabilities of the server.  APOP
 634 is added as a pseudo capability.  Note that I've been unable to
 635 find a list of the standard capability values, and some appear to
 636 be multi-word and some are not.  We make an attempt at intelligently
 637 parsing them, but it may not be correct.
 638
 639 =item  capabilities ()
 640
 641 Just like capa, but only uses a cache from the last time we asked
 642 the server, so as to avoid asking more than once.
 643
 644 =item top ( MSGNUM [, NUMLINES ] )
 645
 646 Get the header and the first C<NUMLINES> of the body for the message
 647 C<MSGNUM>. Returns a reference to an array which contains the lines of text
 648 read from the server.
 649
 650 =item list ( [ MSGNUM ] )
 651
 652 If called with an argument the C<list> returns the size of the message
 653 in octets.
 654
 655 If called without arguments a reference to a hash is returned. The
 656 keys will be the C<MSGNUM>'s of all undeleted messages and the values will
 657 be their size in octets.
 658
 659 =item get ( MSGNUM [, FH ] )
 660
 661 Get the message C<MSGNUM> from the remote mailbox. If C<FH> is not given
 662 then get returns a reference to an array which contains the lines of
 663 text read from the server. If C<FH> is given then the lines returned
 664 from the server are printed to the filehandle C<FH>.
 665
 666 =item getfh ( MSGNUM )
 667
 668 As per get(), but returns a tied filehandle.  Reading from this
 669 filehandle returns the requested message.  The filehandle will return
 670 EOF at the end of the message and should not be reused.
 671
 672 =item last ()
 673
 674 Returns the highest C<MSGNUM> of all the messages accessed.
 675
 676 =item popstat ()
 677
 678 Returns a list of two elements. These are the number of undeleted
 679 elements and the size of the mbox in octets.
 680
 681 =item ping ( USER )
 682
 683 Returns a list of two elements. These are the number of new messages
 684 and the total number of messages for C<USER>.
 685
 686 =item uidl ( [ MSGNUM ] )
 687
 688 Returns a unique identifier for C<MSGNUM> if given. If C<MSGNUM> is not
 689 given C<uidl> returns a reference to a hash where the keys are the
 690 message numbers and the values are the unique identifiers.
 691
 692 =item delete ( MSGNUM )
 693
 694 Mark message C<MSGNUM> to be deleted from the remote mailbox. All messages
 695 that are marked to be deleted will be removed from the remote mailbox
 696 when the server connection closed.
 697
 698 =item reset ()
 699
 700 Reset the status of the remote POP3 server. This includes resetting the
 701 status of all messages to not be deleted.
 702
 703 =item quit ()
 704
 705 Quit and close the connection to the remote POP3 server. Any messages marked
 706 as deleted will be deleted from the remote mailbox.
 707
 708 =back
 709
 710 =head1 NOTES
 711
 712 If a C<Net::POP3> object goes out of scope before C<quit> method is called
 713 then the C<reset> method will called before the connection is closed. This
 714 means that any messages marked to be deleted will not be.
 715
 716 =head1 SEE ALSO
 717
 718 L<Net::Netrc>,
 719 L<Net::Cmd>
 720
 721 =head1 AUTHOR
 722
 723 Graham Barr <gbarr@pobox.com>
 724
 725 =head1 COPYRIGHT
 726
 727 Copyright (c) 1995-2003 Graham Barr. All rights reserved.
 728 This program is free software; you can redistribute it and/or modify
 729 it under the same terms as Perl itself.
 730
 731 =cut