This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade to libnet-1.20. Includes some additional version bumps where bleadperl
[perl5.git] / 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