lib/Net/POP3.pm

   1 # Net::POP3.pm
   2 #
   3 # Copyright (c) 1995 Graham Barr <Graham.Barr@tiuk.ti.com>. All rights
   4 # reserved. 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 =head1 NAME
  10
  11 Net::POP3 - Post Office Protocol 3 Client class (RFC1081)
  12
  13 =head1 SYNOPSIS
  14
  15     use Net::POP3;
  16
  17     # Constructors
  18     $pop = Net::POP3->new('pop3host');
  19     $pop = Net::POP3->new('pop3host', Timeout => 60);
  20
  21 =head1 DESCRIPTION
  22
  23 This module implements a client interface to the POP3 protocol, enabling
  24 a perl5 application to talk to POP3 servers. This documentation assumes
  25 that you are familiar with the POP3 protocol described in RFC1081.
  26
  27 A new Net::POP3 object must be created with the I<new> method. Once
  28 this has been done, all POP3 commands are accessed via method calls
  29 on the object.
  30
  31 =head1 EXAMPLES
  32
  33     Need some small examples in here :-)
  34
  35 =head1 CONSTRUCTOR
  36
  37 =over 4
  38
  39 =item new ( HOST, [ OPTIONS ] )
  40
  41 This is the constructor for a new Net::POP3 object. C<HOST> is the
  42 name of the remote host to which a POP3 connection is required.
  43
  44 C<OPTIONS> are passed in a hash like fasion, using key and value pairs.
  45 Possible options are:
  46
  47 B<Timeout> - Maximum time, in seconds, to wait for a response from the
  48 POP3 server (default: 120)
  49
  50 B<Debug> - Enable debugging information
  51
  52 =back
  53
  54 =head1 METHODS
  55
  56 Unless otherwise stated all methods return either a I<true> or I<false>
  57 value, with I<true> meaning that the operation was a success. When a method
  58 states that it returns a value, falure will be returned as I<undef> or an
  59 empty list.
  60
  61 =over 4
  62
  63 =item user ( USER )
  64
  65 Send the USER command.
  66
  67 =item pass ( PASS )
  68
  69 Send the PASS command. Returns the number of messages in the mailbox.
  70
  71 =item login ( [ USER [, PASS ]] )
  72
  73 Send both the the USER and PASS commands. If C<PASS> is not given the
  74 C<Net::POP3> uses C<Net::Netrc> to lookup the password using the host
  75 and username. If the username is not specified then the current user name
  76 will be used.
  77
  78 Returns the number of messages in the mailbox.
  79
  80 =item top ( MSGNUM [, NUMLINES ] )
  81
  82 Get the header and the first C<NUMLINES> of the body for the message
  83 C<MSGNUM>. Returns a reference to an array which contains the lines of text
  84 read from the server.
  85
  86 =item list ( [ MSGNUM ] )
  87
  88 If called with an argument the C<list> returns the size of the messsage
  89 in octets.
  90
  91 If called without arguments the a refererence to a hash is returned. The
  92 keys will be the C<MSGNUM>'s of all undeleted messages and the values will
  93 be their size in octets.
  94
  95 =item get ( MSGNUM )
  96
  97 Get the message C<MSGNUM> from the remote mailbox. Returns a reference to an
  98 array which contains the lines of text read from the server.
  99
 100 =item last ()
 101
 102 Returns the highest C<MSGNUM> of all the messages accessed.
 103
 104 =item popstat ()
 105
 106 Returns an array of two elements. These are the number of undeleted
 107 elements and the size of the mbox in octets.
 108
 109 =item delete ( MSGNUM )
 110
 111 Mark message C<MSGNUM> to be deleted from the remote mailbox. All messages
 112 that are marked to be deleted will be removed from the remote mailbox
 113 when the server connection closed.
 114
 115 =item reset ()
 116
 117 Reset the status of the remote POP3 server. This includes reseting the
 118 status of all messages to not be deleted.
 119
 120 =item quit ()
 121
 122 Quit and close the connection to the remote POP3 server. Any messages marked
 123 as deleted will be deleted from the remote mailbox.
 124
 125 =back
 126
 127 =head1 NOTES
 128
 129 If a C<Net::POP3> object goes out of scope before C<quit> method is called
 130 then the C<reset> method will called before the connection is closed. This
 131 means that any messages marked to be deleted will not be.
 132
 133 =head1 SEE ALSO
 134
 135 L<Net::Netrc>
 136 L<Net::Cmd>
 137
 138 =head1 AUTHOR
 139
 140 Graham Barr <Graham.Barr@tiuk.ti.com>
 141
 142 =head1 REVISION
 143
 144 $Revision: 2.1 $
 145 $Date: 1996/07/26 06:44:44 $
 146
 147 The VERSION is derived from the revision by changing each number after the
 148 first dot into a 2 digit number so
 149
 150         Revision 1.8   => VERSION 1.08
 151         Revision 1.2.3 => VERSION 1.0203
 152
 153 =head1 COPYRIGHT
 154
 155 Copyright (c) 1995 Graham Barr. All rights reserved. This program is free
 156 software; you can redistribute it and/or modify it under the same terms
 157 as Perl itself.
 158
 159 =cut
 160
 161 use strict;
 162 use IO::Socket;
 163 use vars qw(@ISA $VERSION $debug);
 164 use Net::Cmd;
 165 use Carp;
 166
 167 $VERSION = do{my @r=(q$Revision: 2.1 $=~/(\d+)/g);sprintf "%d."."%02d"x$#r,@r};
 168
 169 @ISA = qw(Net::Cmd IO::Socket::INET);
 170
 171 sub new
 172 {
 173  my $self = shift;
 174  my $type = ref($self) || $self;
 175  my $host = shift;
 176  my %arg  = @_;
 177  my $obj = $type->SUPER::new(PeerAddr => $host,
 178                              PeerPort => $arg{Port} || 'pop3(110)',
 179                              Proto    => 'tcp',
 180                              Timeout  => defined $arg{Timeout}
 181                                                 ? $arg{Timeout}
 182                                                 : 120
 183                             ) or return undef;
 184
 185  ${*$obj}{'net_pop3_host'} = $host;
 186
 187  $obj->autoflush(1);
 188  $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef);
 189
 190  unless ($obj->response() == CMD_OK)
 191   {
 192    $obj->close();
 193    return undef;
 194   }
 195
 196  $obj;
 197 }
 198
 199 ##
 200 ## We don't want people sending me their passwords when they report problems
 201 ## now do we :-)
 202 ##
 203
 204 sub debug_text { $_[2] =~ /^(pass|rpop)/i ? "$1 ....\n" : $_[2]; }
 205
 206 sub login
 207 {
 208  @_ >= 1 && @_ <= 3 or croak 'usage: $pop3->login( USER, PASS )';
 209  my($me,$user,$pass) = @_;
 210
 211  if(@_ < 2)
 212   {
 213    require Net::Netrc;
 214
 215    $user ||= (getpwuid($>))[0];
 216
 217    my $m = Net::Netrc->lookup(${*$me}{'net_pop3_host'},$user);
 218
 219    $m ||= Net::Netrc->lookup(${*$me}{'net_pop3_host'});
 220
 221    $pass = $m ? $m->password || ""
 222               : "";
 223   }
 224
 225  $me->user($user) and
 226     $me->pass($pass);
 227 }
 228
 229 sub user
 230 {
 231  @_ == 2 or croak 'usage: $pop3->user( USER )';
 232  $_[0]->_USER($_[1]);
 233 }
 234
 235 sub pass
 236 {
 237  @_ == 2 or croak 'usage: $pop3->pass( PASS )';
 238
 239  my($me,$pass) = @_;
 240
 241  return undef
 242    unless($me->_PASS($pass));
 243
 244  $me->message =~ /(\d+)\s+message/io;
 245
 246  ${*$me}{'net_pop3_count'} = $1 || 0;
 247 }
 248
 249 sub reset
 250 {
 251  @_ == 1 or croak 'usage: $obj->reset()';
 252
 253  my $me = shift;
 254
 255  return 0
 256    unless($me->_RSET);
 257
 258  if(defined ${*$me}{'net_pop3_mail'})
 259   {
 260    local $_;
 261    foreach (@{${*$me}{'net_pop3_mail'}})
 262     {
 263      delete $_->{'net_pop3_deleted'};
 264     }
 265   }
 266 }
 267
 268 sub last
 269 {
 270  @_ == 1 or croak 'usage: $obj->last()';
 271
 272  return undef
 273     unless $_[0]->_LAST && $_[0]->message =~ /(\d+)/;
 274
 275  return $1;
 276 }
 277
 278 sub top
 279 {
 280  @_ == 2 || @_ == 3 or croak 'usage: $pop3->top( MSGNUM [, NUMLINES ])';
 281  my $me = shift;
 282
 283  return undef
 284     unless $me->_TOP($_[0], $_[1] || 0);
 285
 286  $me->read_until_dot;
 287 }
 288
 289 sub popstat
 290 {
 291  @_ == 1 or croak 'usage: $pop3->popstat()';
 292  my $me = shift;
 293
 294  return ()
 295     unless $me->_STAT && $me->message =~ /(\d+)\D+(\d+)/;
 296
 297  ($1 || 0, $2 || 0);
 298 }
 299
 300 sub list
 301 {
 302  @_ == 1 || @_ == 2 or croak 'usage: $pop3->list( [ MSGNUM ] )';
 303  my $me = shift;
 304
 305  return undef
 306     unless $me->_LIST(@_);
 307
 308  if(@_)
 309   {
 310    $me->message =~ /\d+\D+(\d+)/;
 311    return $1 || undef;
 312   }
 313
 314  my $info = $me->read_until_dot;
 315  my %hash = ();
 316  map { /(\d+)\D+(\d+)/; $hash{$1} = $2; } @$info;
 317
 318  return \%hash;
 319 }
 320
 321 sub get
 322 {
 323  @_ == 2 or croak 'usage: $pop3->get( MSGNUM )';
 324  my $me = shift;
 325
 326  return undef
 327     unless $me->_RETR(@_);
 328
 329  $me->read_until_dot;
 330 }
 331
 332 sub delete
 333 {
 334  @_ == 2 or croak 'usage: $pop3->delete( MSGNUM )';
 335  $_[0]->_DELE($_[1]);
 336 }
 337
 338 sub _USER { shift->command('USER',$_[0])->response() == CMD_OK }
 339 sub _PASS { shift->command('PASS',$_[0])->response() == CMD_OK }
 340 sub _RPOP { shift->command('RPOP',$_[0])->response() == CMD_OK }
 341 sub _RETR { shift->command('RETR',$_[0])->response() == CMD_OK }
 342 sub _DELE { shift->command('DELE',$_[0])->response() == CMD_OK }
 343 sub _TOP  { shift->command('TOP', @_)->response() == CMD_OK }
 344 sub _LIST { shift->command('LIST',@_)->response() == CMD_OK }
 345 sub _NOOP { shift->command('NOOP')->response() == CMD_OK }
 346 sub _RSET { shift->command('RSET')->response() == CMD_OK }
 347 sub _LAST { shift->command('LAST')->response() == CMD_OK }
 348 sub _QUIT { shift->command('QUIT')->response() == CMD_OK }
 349 sub _STAT { shift->command('STAT')->response() == CMD_OK }
 350
 351 sub close
 352 {
 353  my $me = shift;
 354
 355  return 1
 356    unless (ref($me) && defined fileno($me));
 357
 358  $me->_QUIT && $me->SUPER::close;
 359 }
 360
 361 sub quit    { shift->close }
 362
 363 sub DESTROY
 364 {
 365  my $me = shift;
 366
 367  if(fileno($me))
 368   {
 369    $me->reset;
 370    $me->quit;
 371   }
 372 }
 373
 374 ##
 375 ## POP3 has weird responses, so we emulate them to look the same :-)
 376 ##
 377
 378 sub response
 379 {
 380  my $cmd = shift;
 381  my $str = $cmd->getline() || return undef;
 382  my $code = "500";
 383
 384  $cmd->debug_print(0,$str)
 385    if ($cmd->debug);
 386
 387  if($str =~ s/^\+OK\s+//io)
 388   {
 389    $code = "200"
 390   }
 391  else
 392   {
 393    $str =~ s/^\+ERR\s+//io;
 394   }
 395
 396  ${*$cmd}{'net_cmd_resp'} = [ $str ];
 397  ${*$cmd}{'net_cmd_code'} = $code;
 398
 399  substr($code,0,1);
 400 }
 401
 402 1;