cpan/libnet/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.30";
  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 sub _RPOP { shift->command('RPOP', $_[0])->response() == CMD_OK }
 324 sub _LAST { shift->command('LAST'       )->response() == CMD_OK }
 325 sub _CAPA { shift->command('CAPA'       )->response() == CMD_OK }
 326
 327
 328 sub quit {
 329   my $me = shift;
 330
 331   $me->_QUIT;
 332   $me->close;
 333 }
 334
 335
 336 sub DESTROY {
 337   my $me = shift;
 338
 339   if (defined fileno($me) and ${*$me}{'net_pop3_deleted'}) {
 340     $me->reset;
 341     $me->quit;
 342   }
 343 }
 344
 345 ##
 346 ## POP3 has weird responses, so we emulate them to look the same :-)
 347 ##
 348
 349
 350 sub response {
 351   my $cmd  = shift;
 352   my $str  = $cmd->getline() or return undef;
 353   my $code = "500";
 354
 355   $cmd->debug_print(0, $str)
 356     if ($cmd->debug);
 357
 358   if ($str =~ s/^\+OK\s*//io) {
 359     $code = "200";
 360   }
 361   elsif ($str =~ s/^\+\s*//io) {
 362     $code = "300";
 363   }
 364   else {
 365     $str =~ s/^-ERR\s*//io;
 366   }
 367
 368   ${*$cmd}{'net_cmd_resp'} = [$str];
 369   ${*$cmd}{'net_cmd_code'} = $code;
 370
 371   substr($code, 0, 1);
 372 }
 373
 374
 375 sub capa {
 376   my $this = shift;
 377   my ($capa, %capabilities);
 378
 379   # Fake a capability here
 380   $capabilities{APOP} = '' if ($this->banner() =~ /<.*>/);
 381
 382   if ($this->_CAPA()) {
 383     $capabilities{CAPA} = 1;
 384     $capa = $this->read_until_dot();
 385     %capabilities = (%capabilities, map {/^\s*(\S+)\s*(.*)/} @$capa);
 386   }
 387   else {
 388
 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
 400 sub capabilities {
 401   my $this = shift;
 402
 403   ${*$this}{'net_pop3e_capabilities'} || $this->capa;
 404 }
 405
 406
 407 sub auth {
 408   my ($self, $username, $password) = @_;
 409
 410   eval {
 411     require MIME::Base64;
 412     require Authen::SASL;
 413   } or $self->set_status(500, ["Need MIME::Base64 and Authen::SASL todo auth"]), return 0;
 414
 415   my $capa       = $self->capa;
 416   my $mechanisms = $capa->{SASL} || 'CRAM-MD5';
 417
 418   my $sasl;
 419
 420   if (ref($username) and UNIVERSAL::isa($username, 'Authen::SASL')) {
 421     $sasl = $username;
 422     my $user_mech = $sasl->mechanism || '';
 423     my @user_mech = split(/\s+/, $user_mech);
 424     my %user_mech;
 425     @user_mech{@user_mech} = ();
 426
 427     my @server_mech = split(/\s+/, $mechanisms);
 428     my @mech = @user_mech
 429       ? grep { exists $user_mech{$_} } @server_mech
 430       : @server_mech;
 431     unless (@mech) {
 432       $self->set_status(
 433         500,
 434         [ 'Client SASL mechanisms (',
 435           join(', ', @user_mech),
 436           ') do not match the SASL mechnism the server announces (',
 437           join(', ', @server_mech), ')',
 438         ]
 439       );
 440       return 0;
 441     }
 442
 443     $sasl->mechanism(join(" ", @mech));
 444   }
 445   else {
 446     die "auth(username, password)" if not length $username;
 447     $sasl = Authen::SASL->new(
 448       mechanism => $mechanisms,
 449       callback  => {
 450         user     => $username,
 451         pass     => $password,
 452         authname => $username,
 453       }
 454     );
 455   }
 456
 457   # We should probably allow the user to pass the host, but I don't
 458   # currently know and SASL mechanisms that are used by smtp that need it
 459   my ($hostname) = split /:/, ${*$self}{'net_pop3_host'};
 460   my $client = eval { $sasl->client_new('pop', $hostname, 0) };
 461
 462   unless ($client) {
 463     my $mech = $sasl->mechanism;
 464     $self->set_status(
 465       500,
 466       [ " Authen::SASL failure: $@",
 467         '(please check if your local Authen::SASL installation',
 468         "supports mechanism '$mech'"
 469       ]
 470     );
 471     return 0;
 472   }
 473
 474   my ($token) = $client->client_start
 475     or do {
 476     my $mech = $client->mechanism;
 477     $self->set_status(
 478       500,
 479       [ ' Authen::SASL failure:  $client->client_start ',
 480         "mechanism '$mech' hostname #$hostname#",
 481         $client->error
 482       ]
 483     );
 484     return 0;
 485     };
 486
 487   # We don't support sasl mechanisms that encrypt the socket traffic.
 488   # todo that we would really need to change the ISA hierarchy
 489   # so we don't inherit from IO::Socket, but instead hold it in an attribute
 490
 491   my @cmd = ("AUTH", $client->mechanism);
 492   my $code;
 493
 494   push @cmd, MIME::Base64::encode_base64($token, '')
 495     if defined $token and length $token;
 496
 497   while (($code = $self->command(@cmd)->response()) == CMD_MORE) {
 498
 499     my ($token) = $client->client_step(MIME::Base64::decode_base64(($self->message)[0])) or do {
 500       $self->set_status(
 501         500,
 502         [ ' Authen::SASL failure:  $client->client_step ',
 503           "mechanism '", $client->mechanism, " hostname #$hostname#, ",
 504           $client->error
 505         ]
 506       );
 507       return 0;
 508     };
 509
 510     @cmd = (MIME::Base64::encode_base64(defined $token ? $token : '', ''));
 511   }
 512
 513   $code == CMD_OK;
 514 }
 515
 516
 517 sub banner {
 518   my $this = shift;
 519
 520   return ${*$this}{'net_pop3_banner'};
 521 }
 522
 523 1;
 524
 525 __END__
 526
 527 =head1 NAME
 528
 529 Net::POP3 - Post Office Protocol 3 Client class (RFC1939)
 530
 531 =head1 SYNOPSIS
 532
 533     use Net::POP3;
 534
 535     # Constructors
 536     $pop = Net::POP3->new('pop3host');
 537     $pop = Net::POP3->new('pop3host', Timeout => 60);
 538
 539     if ($pop->login($username, $password) > 0) {
 540       my $msgnums = $pop->list; # hashref of msgnum => size
 541       foreach my $msgnum (keys %$msgnums) {
 542         my $msg = $pop->get($msgnum);
 543         print @$msg;
 544         $pop->delete($msgnum);
 545       }
 546     }
 547
 548     $pop->quit;
 549
 550 =head1 DESCRIPTION
 551
 552 This module implements a client interface to the POP3 protocol, enabling
 553 a perl5 application to talk to POP3 servers. This documentation assumes
 554 that you are familiar with the POP3 protocol described in RFC1939.
 555
 556 A new Net::POP3 object must be created with the I<new> method. Once
 557 this has been done, all POP3 commands are accessed via method calls
 558 on the object.
 559
 560 =head1 CONSTRUCTOR
 561
 562 =over 4
 563
 564 =item new ( [ HOST ] [, OPTIONS ] )
 565
 566 This is the constructor for a new Net::POP3 object. C<HOST> is the
 567 name of the remote host to which an POP3 connection is required.
 568
 569 C<HOST> is optional. If C<HOST> is not given then it may instead be
 570 passed as the C<Host> option described below. If neither is given then
 571 the C<POP3_Hosts> specified in C<Net::Config> will be used.
 572
 573 C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
 574 Possible options are:
 575
 576 B<Host> - POP3 host to connect to. It may be a single scalar, as defined for
 577 the C<PeerAddr> option in L<IO::Socket::INET>, or a reference to
 578 an array with hosts to try in turn. The L</host> method will return the value
 579 which was used to connect to the host.
 580
 581 B<ResvPort> - If given then the socket for the C<Net::POP3> object
 582 will be bound to the local port given using C<bind> when the socket is
 583 created.
 584
 585 B<Timeout> - Maximum time, in seconds, to wait for a response from the
 586 POP3 server (default: 120)
 587
 588 B<Debug> - Enable debugging information
 589
 590 =back
 591
 592 =head1 METHODS
 593
 594 Unless otherwise stated all methods return either a I<true> or I<false>
 595 value, with I<true> meaning that the operation was a success. When a method
 596 states that it returns a value, failure will be returned as I<undef> or an
 597 empty list.
 598
 599 =over 4
 600
 601 =item auth ( USERNAME, PASSWORD )
 602
 603 Attempt SASL authentication.
 604
 605 =item user ( USER )
 606
 607 Send the USER command.
 608
 609 =item pass ( PASS )
 610
 611 Send the PASS command. Returns the number of messages in the mailbox.
 612
 613 =item login ( [ USER [, PASS ]] )
 614
 615 Send both the USER and PASS commands. If C<PASS> is not given the
 616 C<Net::POP3> uses C<Net::Netrc> to lookup the password using the host
 617 and username. If the username is not specified then the current user name
 618 will be used.
 619
 620 Returns the number of messages in the mailbox. However if there are no
 621 messages on the server the string C<"0E0"> will be returned. This is
 622 will give a true value in a boolean context, but zero in a numeric context.
 623
 624 If there was an error authenticating the user then I<undef> will be returned.
 625
 626 =item apop ( [ USER [, PASS ]] )
 627
 628 Authenticate with the server identifying as C<USER> with password C<PASS>.
 629 Similar to L</login>, but the password is not sent in clear text.
 630
 631 To use this method you must have the Digest::MD5 or the MD5 module installed,
 632 otherwise this method will return I<undef>.
 633
 634 =item banner ()
 635
 636 Return the sever's connection banner
 637
 638 =item capa ()
 639
 640 Return a reference to a hash of the capabilities of the server.  APOP
 641 is added as a pseudo capability.  Note that I've been unable to
 642 find a list of the standard capability values, and some appear to
 643 be multi-word and some are not.  We make an attempt at intelligently
 644 parsing them, but it may not be correct.
 645
 646 =item  capabilities ()
 647
 648 Just like capa, but only uses a cache from the last time we asked
 649 the server, so as to avoid asking more than once.
 650
 651 =item top ( MSGNUM [, NUMLINES ] )
 652
 653 Get the header and the first C<NUMLINES> of the body for the message
 654 C<MSGNUM>. Returns a reference to an array which contains the lines of text
 655 read from the server.
 656
 657 =item list ( [ MSGNUM ] )
 658
 659 If called with an argument the C<list> returns the size of the message
 660 in octets.
 661
 662 If called without arguments a reference to a hash is returned. The
 663 keys will be the C<MSGNUM>'s of all undeleted messages and the values will
 664 be their size in octets.
 665
 666 =item get ( MSGNUM [, FH ] )
 667
 668 Get the message C<MSGNUM> from the remote mailbox. If C<FH> is not given
 669 then get returns a reference to an array which contains the lines of
 670 text read from the server. If C<FH> is given then the lines returned
 671 from the server are printed to the filehandle C<FH>.
 672
 673 =item getfh ( MSGNUM )
 674
 675 As per get(), but returns a tied filehandle.  Reading from this
 676 filehandle returns the requested message.  The filehandle will return
 677 EOF at the end of the message and should not be reused.
 678
 679 =item last ()
 680
 681 Returns the highest C<MSGNUM> of all the messages accessed.
 682
 683 =item popstat ()
 684
 685 Returns a list of two elements. These are the number of undeleted
 686 elements and the size of the mbox in octets.
 687
 688 =item ping ( USER )
 689
 690 Returns a list of two elements. These are the number of new messages
 691 and the total number of messages for C<USER>.
 692
 693 =item uidl ( [ MSGNUM ] )
 694
 695 Returns a unique identifier for C<MSGNUM> if given. If C<MSGNUM> is not
 696 given C<uidl> returns a reference to a hash where the keys are the
 697 message numbers and the values are the unique identifiers.
 698
 699 =item delete ( MSGNUM )
 700
 701 Mark message C<MSGNUM> to be deleted from the remote mailbox. All messages
 702 that are marked to be deleted will be removed from the remote mailbox
 703 when the server connection closed.
 704
 705 =item reset ()
 706
 707 Reset the status of the remote POP3 server. This includes resetting the
 708 status of all messages to not be deleted.
 709
 710 =item quit ()
 711
 712 Quit and close the connection to the remote POP3 server. Any messages marked
 713 as deleted will be deleted from the remote mailbox.
 714
 715 =back
 716
 717 =head1 NOTES
 718
 719 If a C<Net::POP3> object goes out of scope before C<quit> method is called
 720 then the C<reset> method will called before the connection is closed. This
 721 means that any messages marked to be deleted will not be.
 722
 723 =head1 SEE ALSO
 724
 725 L<Net::Netrc>,
 726 L<Net::Cmd>
 727
 728 =head1 AUTHOR
 729
 730 Graham Barr <gbarr@pobox.com>
 731
 732 =head1 COPYRIGHT
 733
 734 Copyright (c) 1995-2003 Graham Barr. All rights reserved.
 735 This program is free software; you can redistribute it and/or modify
 736 it under the same terms as Perl itself.
 737
 738 =cut