This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade libnet from version 1.24 to 1.25
[perl5.git] / 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.31";
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 The Net::POP3 class is a subclass of Net::Cmd and IO::Socket::INET.
561
562 =head1 CONSTRUCTOR
563
564 =over 4
565
566 =item new ( [ HOST ] [, OPTIONS ] )
567
568 This is the constructor for a new Net::POP3 object. C<HOST> is the
569 name of the remote host to which an POP3 connection is required.
570
571 C<HOST> is optional. If C<HOST> is not given then it may instead be
572 passed as the C<Host> option described below. If neither is given then
573 the C<POP3_Hosts> specified in C<Net::Config> will be used.
574
575 C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
576 Possible options are:
577
578 B<Host> - POP3 host to connect to. It may be a single scalar, as defined for
579 the C<PeerAddr> option in L<IO::Socket::INET>, or a reference to
580 an array with hosts to try in turn. The L</host> method will return the value
581 which was used to connect to the host.
582
583 B<ResvPort> - If given then the socket for the C<Net::POP3> object
584 will be bound to the local port given using C<bind> when the socket is
585 created.
586
587 B<Timeout> - Maximum time, in seconds, to wait for a response from the
588 POP3 server (default: 120)
589
590 B<Debug> - Enable debugging information
591
592 =back
593
594 =head1 METHODS
595
596 Unless otherwise stated all methods return either a I<true> or I<false>
597 value, with I<true> meaning that the operation was a success. When a method
598 states that it returns a value, failure will be returned as I<undef> or an
599 empty list.
600
601 C<Net::POP3> inherits from C<Net::Cmd> so methods defined in C<Net::Cmd> may
602 be used to send commands to the remote POP3 server in addition to the methods
603 documented here.
604
605 =over 4
606
607 =item auth ( USERNAME, PASSWORD )
608
609 Attempt SASL authentication.
610
611 =item user ( USER )
612
613 Send the USER command.
614
615 =item pass ( PASS )
616
617 Send the PASS command. Returns the number of messages in the mailbox.
618
619 =item login ( [ USER [, PASS ]] )
620
621 Send both the USER and PASS commands. If C<PASS> is not given the
622 C<Net::POP3> uses C<Net::Netrc> to lookup the password using the host
623 and username. If the username is not specified then the current user name
624 will be used.
625
626 Returns the number of messages in the mailbox. However if there are no
627 messages on the server the string C<"0E0"> will be returned. This is
628 will give a true value in a boolean context, but zero in a numeric context.
629
630 If there was an error authenticating the user then I<undef> will be returned.
631
632 =item apop ( [ USER [, PASS ]] )
633
634 Authenticate with the server identifying as C<USER> with password C<PASS>.
635 Similar to L</login>, but the password is not sent in clear text.
636
637 To use this method you must have the Digest::MD5 or the MD5 module installed,
638 otherwise this method will return I<undef>.
639
640 =item banner ()
641
642 Return the sever's connection banner
643
644 =item capa ()
645
646 Return a reference to a hash of the capabilities of the server.  APOP
647 is added as a pseudo capability.  Note that I've been unable to
648 find a list of the standard capability values, and some appear to
649 be multi-word and some are not.  We make an attempt at intelligently
650 parsing them, but it may not be correct.
651
652 =item  capabilities ()
653
654 Just like capa, but only uses a cache from the last time we asked
655 the server, so as to avoid asking more than once.
656
657 =item top ( MSGNUM [, NUMLINES ] )
658
659 Get the header and the first C<NUMLINES> of the body for the message
660 C<MSGNUM>. Returns a reference to an array which contains the lines of text
661 read from the server.
662
663 =item list ( [ MSGNUM ] )
664
665 If called with an argument the C<list> returns the size of the message
666 in octets.
667
668 If called without arguments a reference to a hash is returned. The
669 keys will be the C<MSGNUM>'s of all undeleted messages and the values will
670 be their size in octets.
671
672 =item get ( MSGNUM [, FH ] )
673
674 Get the message C<MSGNUM> from the remote mailbox. If C<FH> is not given
675 then get returns a reference to an array which contains the lines of
676 text read from the server. If C<FH> is given then the lines returned
677 from the server are printed to the filehandle C<FH>.
678
679 =item getfh ( MSGNUM )
680
681 As per get(), but returns a tied filehandle.  Reading from this
682 filehandle returns the requested message.  The filehandle will return
683 EOF at the end of the message and should not be reused.
684
685 =item last ()
686
687 Returns the highest C<MSGNUM> of all the messages accessed.
688
689 =item popstat ()
690
691 Returns a list of two elements. These are the number of undeleted
692 elements and the size of the mbox in octets.
693
694 =item ping ( USER )
695
696 Returns a list of two elements. These are the number of new messages
697 and the total number of messages for C<USER>.
698
699 =item uidl ( [ MSGNUM ] )
700
701 Returns a unique identifier for C<MSGNUM> if given. If C<MSGNUM> is not
702 given C<uidl> returns a reference to a hash where the keys are the
703 message numbers and the values are the unique identifiers.
704
705 =item delete ( MSGNUM )
706
707 Mark message C<MSGNUM> to be deleted from the remote mailbox. All messages
708 that are marked to be deleted will be removed from the remote mailbox
709 when the server connection closed.
710
711 =item reset ()
712
713 Reset the status of the remote POP3 server. This includes resetting the
714 status of all messages to not be deleted.
715
716 =item quit ()
717
718 Quit and close the connection to the remote POP3 server. Any messages marked
719 as deleted will be deleted from the remote mailbox.
720
721 =back
722
723 =head1 NOTES
724
725 If a C<Net::POP3> object goes out of scope before C<quit> method is called
726 then the C<reset> method will called before the connection is closed. This
727 means that any messages marked to be deleted will not be.
728
729 =head1 SEE ALSO
730
731 L<Net::Netrc>,
732 L<Net::Cmd>
733
734 =head1 AUTHOR
735
736 Graham Barr <gbarr@pobox.com>
737
738 =head1 COPYRIGHT
739
740 Copyright (c) 1995-2003 Graham Barr. All rights reserved.
741 This program is free software; you can redistribute it and/or modify
742 it under the same terms as Perl itself.
743
744 =cut