This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Initial integration of libnet-1.0703.
[perl5.git] / lib / Net / POP3.pm
1 # Net::POP3.pm
2 #
3 # Copyright (c) 1995-1997 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.21"; # $Id$
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 = shift if @_ % 2;
25  my %arg  = @_; 
26  my $hosts = defined $host ? [ $host ] : $NetConfig{pop3_hosts};
27  my $obj;
28  my @localport = exists $arg{ResvPort} ? ( LocalPort => $arg{ResvPort} ): ();
29
30  my $h;
31  foreach $h (@{$hosts})
32   {
33    $obj = $type->SUPER::new(PeerAddr => ($host = $h), 
34                             PeerPort => $arg{Port} || 'pop3(110)',
35                             Proto    => 'tcp',
36                             @localport,
37                             Timeout  => defined $arg{Timeout}
38                                                 ? $arg{Timeout}
39                                                 : 120
40                            ) and last;
41   }
42
43  return undef
44         unless defined $obj;
45
46  ${*$obj}{'net_pop3_host'} = $host;
47
48  $obj->autoflush(1);
49  $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef);
50
51  unless ($obj->response() == CMD_OK)
52   {
53    $obj->close();
54    return undef;
55   }
56
57  ${*$obj}{'net_pop3_banner'} = $obj->message;
58
59  $obj;
60 }
61
62 ##
63 ## We don't want people sending me their passwords when they report problems
64 ## now do we :-)
65 ##
66
67 sub debug_text { $_[2] =~ /^(pass|rpop)/i ? "$1 ....\n" : $_[2]; }
68
69 sub login
70 {
71  @_ >= 1 && @_ <= 3 or croak 'usage: $pop3->login( USER, PASS )';
72  my($me,$user,$pass) = @_;
73
74  if(@_ <= 2)
75   {
76    require Net::Netrc;
77
78    $user ||= eval { (getpwuid($>))[0] } || $ENV{NAME};
79
80    my $m = Net::Netrc->lookup(${*$me}{'net_pop3_host'},$user);
81
82    $m ||= Net::Netrc->lookup(${*$me}{'net_pop3_host'});
83
84    $pass = $m ? $m->password || ""
85               : "";
86   }
87
88  $me->user($user) and
89     $me->pass($pass);
90 }
91
92 sub apop
93 {
94  @_ >= 1 && @_ <= 3 or croak 'usage: $pop3->apop( USER, PASS )';
95  my($me,$user,$pass) = @_;
96  my $banner;
97
98  unless(eval { require MD5 })
99   {
100    carp "You need to install MD5 to use the APOP command";
101    return undef;
102   }
103
104  return undef
105    unless ( $banner = (${*$me}{'net_pop3_banner'} =~ /(<.*>)/)[0] );
106
107  if(@_ <= 2)
108   {
109    require Net::Netrc;
110
111    $user ||= eval { (getpwuid($>))[0] } || $ENV{NAME};
112
113    my $m = Net::Netrc->lookup(${*$me}{'net_pop3_host'},$user);
114
115    $m ||= Net::Netrc->lookup(${*$me}{'net_pop3_host'});
116
117    $pass = $m ? $m->password || ""
118               : "";
119   }
120
121  my $md = new MD5;
122  $md->add($banner,$pass);
123
124  return undef
125     unless($me->_APOP($user,$md->hexdigest));
126
127  my $ret = ${*$me}{'net_pop3_count'} = ($me->message =~ /(\d+)\s+message/io)
128         ? $1 : ($me->popstat)[0];
129
130  $ret ? $ret : "0E0";
131 }
132
133 sub user
134 {
135  @_ == 2 or croak 'usage: $pop3->user( USER )';
136  $_[0]->_USER($_[1]) ? 1 : undef;
137 }
138
139 sub pass
140 {
141  @_ == 2 or croak 'usage: $pop3->pass( PASS )';
142
143  my($me,$pass) = @_;
144
145  return undef
146    unless($me->_PASS($pass));
147
148  my $ret = ${*$me}{'net_pop3_count'} = ($me->message =~ /(\d+)\s+message/io)
149         ? $1 : ($me->popstat)[0];
150
151  $ret ? $ret : "0E0";
152 }
153
154 sub reset
155 {
156  @_ == 1 or croak 'usage: $obj->reset()';
157
158  my $me = shift;
159
160  return 0 
161    unless($me->_RSET);
162   
163  if(defined ${*$me}{'net_pop3_mail'})
164   {
165    local $_;
166    foreach (@{${*$me}{'net_pop3_mail'}})
167     {
168      delete $_->{'net_pop3_deleted'};
169     }
170   }
171 }
172
173 sub last
174 {
175  @_ == 1 or croak 'usage: $obj->last()';
176
177  return undef
178     unless $_[0]->_LAST && $_[0]->message =~ /(\d+)/;
179
180  return $1;
181 }
182
183 sub top
184 {
185  @_ == 2 || @_ == 3 or croak 'usage: $pop3->top( MSGNUM [, NUMLINES ])';
186  my $me = shift;
187
188  return undef
189     unless $me->_TOP($_[0], $_[1] || 0);
190
191  $me->read_until_dot;
192 }
193
194 sub popstat
195 {
196  @_ == 1 or croak 'usage: $pop3->popstat()';
197  my $me = shift;
198
199  return ()
200     unless $me->_STAT && $me->message =~ /(\d+)\D+(\d+)/;
201
202  ($1 || 0, $2 || 0);
203 }
204
205 sub list
206 {
207  @_ == 1 || @_ == 2 or croak 'usage: $pop3->list( [ MSGNUM ] )';
208  my $me = shift;
209
210  return undef
211     unless $me->_LIST(@_);
212
213  if(@_)
214   {
215    $me->message =~ /\d+\D+(\d+)/;
216    return $1 || undef;
217   }
218  
219  my $info = $me->read_until_dot
220         or return undef;
221
222  my %hash = map { (/(\d+)\D+(\d+)/) } @$info;
223
224  return \%hash;
225 }
226
227 sub get
228 {
229  @_ == 2 or @_ == 3 or croak 'usage: $pop3->get( MSGNUM [, FH ])';
230  my $me = shift;
231
232  return undef
233     unless $me->_RETR(shift);
234
235  $me->read_until_dot(@_);
236 }
237
238 sub delete
239 {
240  @_ == 2 or croak 'usage: $pop3->delete( MSGNUM )';
241  $_[0]->_DELE($_[1]);
242 }
243
244 sub uidl
245 {
246  @_ == 1 || @_ == 2 or croak 'usage: $pop3->uidl( [ MSGNUM ] )';
247  my $me = shift;
248  my $uidl;
249
250  $me->_UIDL(@_) or
251     return undef;
252  if(@_)
253   {
254    $uidl = ($me->message =~ /\d+\s+([\041-\176]+)/)[0];
255   }
256  else
257   {
258    my $ref = $me->read_until_dot
259         or return undef;
260    my $ln;
261    $uidl = {};
262    foreach $ln (@$ref) {
263      my($msg,$uid) = $ln =~ /^\s*(\d+)\s+([\041-\176]+)/;
264      $uidl->{$msg} = $uid;
265    }
266   }
267  return $uidl;
268 }
269
270 sub ping
271 {
272  @_ == 2 or croak 'usage: $pop3->ping( USER )';
273  my $me = shift;
274
275  return () unless $me->_PING(@_) && $me->message =~ /(\d+)\D+(\d+)/;
276
277  ($1 || 0, $2 || 0);
278 }
279
280  
281 sub _STAT { shift->command('STAT')->response() == CMD_OK }
282 sub _LIST { shift->command('LIST',@_)->response() == CMD_OK }
283 sub _RETR { shift->command('RETR',$_[0])->response() == CMD_OK }
284 sub _DELE { shift->command('DELE',$_[0])->response() == CMD_OK }
285 sub _NOOP { shift->command('NOOP')->response() == CMD_OK }
286 sub _RSET { shift->command('RSET')->response() == CMD_OK }
287 sub _QUIT { shift->command('QUIT')->response() == CMD_OK }
288 sub _TOP  { shift->command('TOP', @_)->response() == CMD_OK }
289 sub _UIDL { shift->command('UIDL',@_)->response() == CMD_OK }
290 sub _USER { shift->command('USER',$_[0])->response() == CMD_OK }
291 sub _PASS { shift->command('PASS',$_[0])->response() == CMD_OK }
292 sub _APOP { shift->command('APOP',@_)->response() == CMD_OK }
293 sub _PING { shift->command('PING',$_[0])->response() == CMD_OK }
294
295 sub _RPOP { shift->command('RPOP',$_[0])->response() == CMD_OK }
296 sub _LAST { shift->command('LAST')->response() == CMD_OK }
297
298 sub quit
299 {
300  my $me = shift;
301
302  $me->_QUIT;
303  $me->close;
304 }
305
306 sub DESTROY
307 {
308  my $me = shift;
309
310  if(defined fileno($me))
311   {
312    $me->reset;
313    $me->quit;
314   }
315 }
316
317 ##
318 ## POP3 has weird responses, so we emulate them to look the same :-)
319 ##
320
321 sub response
322 {
323  my $cmd = shift;
324  my $str = $cmd->getline() || return undef;
325  my $code = "500";
326
327  $cmd->debug_print(0,$str)
328    if ($cmd->debug);
329
330  if($str =~ s/^\+OK\s+//io)
331   {
332    $code = "200"
333   }
334  else
335   {
336    $str =~ s/^-ERR\s+//io;
337   }
338
339  ${*$cmd}{'net_cmd_resp'} = [ $str ];
340  ${*$cmd}{'net_cmd_code'} = $code;
341
342  substr($code,0,1);
343 }
344
345 1;
346
347 __END__
348
349 =head1 NAME
350
351 Net::POP3 - Post Office Protocol 3 Client class (RFC1081)
352
353 =head1 SYNOPSIS
354
355     use Net::POP3;
356     
357     # Constructors
358     $pop = Net::POP3->new('pop3host');
359     $pop = Net::POP3->new('pop3host', Timeout => 60);
360
361 =head1 DESCRIPTION
362
363 This module implements a client interface to the POP3 protocol, enabling
364 a perl5 application to talk to POP3 servers. This documentation assumes
365 that you are familiar with the POP3 protocol described in RFC1081.
366
367 A new Net::POP3 object must be created with the I<new> method. Once
368 this has been done, all POP3 commands are accessed via method calls
369 on the object.
370
371 =head1 EXAMPLES
372
373     Need some small examples in here :-)
374
375 =head1 CONSTRUCTOR
376
377 =over 4
378
379 =item new ( [ HOST, ] [ OPTIONS ] )
380
381 This is the constructor for a new Net::POP3 object. C<HOST> is the
382 name of the remote host to which a POP3 connection is required.
383
384 If C<HOST> is not given, then the C<POP3_Host> specified in C<Net::Config>
385 will be used.
386
387 C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
388 Possible options are:
389
390 B<ResvPort> - If given then the socket for the C<Net::POP3> object
391 will be bound to the local port given using C<bind> when the socket is
392 created.
393
394 B<Timeout> - Maximum time, in seconds, to wait for a response from the
395 POP3 server (default: 120)
396
397 B<Debug> - Enable debugging information
398
399 =back
400
401 =head1 METHODS
402
403 Unless otherwise stated all methods return either a I<true> or I<false>
404 value, with I<true> meaning that the operation was a success. When a method
405 states that it returns a value, failure will be returned as I<undef> or an
406 empty list.
407
408 =over 4
409
410 =item user ( USER )
411
412 Send the USER command.
413
414 =item pass ( PASS )
415
416 Send the PASS command. Returns the number of messages in the mailbox.
417
418 =item login ( [ USER [, PASS ]] )
419
420 Send both the the USER and PASS commands. If C<PASS> is not given the
421 C<Net::POP3> uses C<Net::Netrc> to lookup the password using the host
422 and username. If the username is not specified then the current user name
423 will be used.
424
425 Returns the number of messages in the mailbox. However if there are no
426 messages on the server the string C<"0E0"> will be returned. This is
427 will give a true value in a boolean context, but zero in a numeric context.
428
429 If there was an error authenticating the user then I<undef> will be returned.
430
431 =item apop ( USER, PASS )
432
433 Authenticate with the server identifying as C<USER> with password C<PASS>.
434 Similar ti L<login>, but the password is not sent in clear text. 
435
436 To use this method you must have the MD5 package installed, if you do not
437 this method will return I<undef>
438
439
440 =item top ( MSGNUM [, NUMLINES ] )
441
442 Get the header and the first C<NUMLINES> of the body for the message
443 C<MSGNUM>. Returns a reference to an array which contains the lines of text
444 read from the server.
445
446 =item list ( [ MSGNUM ] )
447
448 If called with an argument the C<list> returns the size of the message
449 in octets.
450
451 If called without arguments a reference to a hash is returned. The
452 keys will be the C<MSGNUM>'s of all undeleted messages and the values will
453 be their size in octets.
454
455 =item get ( MSGNUM [, FH ] )
456
457 Get the message C<MSGNUM> from the remote mailbox. If C<FH> is not given
458 then get returns a reference to an array which contains the lines of
459 text read from the server. If C<FH> is given then the lines returned
460 from the server are printed to the filehandle C<FH>.
461
462 =item last ()
463
464 Returns the highest C<MSGNUM> of all the messages accessed.
465
466 =item popstat ()
467
468 Returns a list of two elements. These are the number of undeleted
469 elements and the size of the mbox in octets.
470
471 =item ping ( USER )
472
473 Returns a list of two elements. These are the number of new messages
474 and the total number of messages for C<USER>.
475
476 =item uidl ( [ MSGNUM ] )
477
478 Returns a unique identifier for C<MSGNUM> if given. If C<MSGNUM> is not
479 given C<uidl> returns a reference to a hash where the keys are the
480 message numbers and the values are the unique identifiers.
481
482 =item delete ( MSGNUM )
483
484 Mark message C<MSGNUM> to be deleted from the remote mailbox. All messages
485 that are marked to be deleted will be removed from the remote mailbox
486 when the server connection closed.
487
488 =item reset ()
489
490 Reset the status of the remote POP3 server. This includes reseting the
491 status of all messages to not be deleted.
492
493 =item quit ()
494
495 Quit and close the connection to the remote POP3 server. Any messages marked
496 as deleted will be deleted from the remote mailbox.
497
498 =back
499
500 =head1 NOTES
501
502 If a C<Net::POP3> object goes out of scope before C<quit> method is called
503 then the C<reset> method will called before the connection is closed. This
504 means that any messages marked to be deleted will not be.
505
506 =head1 SEE ALSO
507
508 L<Net::Netrc>
509 L<Net::Cmd>
510
511 =head1 AUTHOR
512
513 Graham Barr <gbarr@pobox.com>
514
515 =head1 COPYRIGHT
516
517 Copyright (c) 1995-1997 Graham Barr. All rights reserved.
518 This program is free software; you can redistribute it and/or modify
519 it under the same terms as Perl itself.
520
521 =cut