Move libnet Net::* to the top level, to mirror the CPAN distribution.
[perl.git] / ext / 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.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