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