[Summary view] [Print] [Text view]

   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