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