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