File Coverage

blib/lib/Mail/POP3Client.pm

Criterion	Covered	Total	%
statement	16	544	2.9
branch	0	330	0.0
condition	0	103	0.0
subroutine	6	64	9.3
pod	31	53	58.4
total	53	1094	4.8

#******************************************************************************
#
# Description:  POP3Client module - acts as interface to POP3 server
# Author:       Sean Dowd
#
# Copyright (c) 1999-2022  Sean Dowd.  All rights reserved.
# This module is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself.
#
#******************************************************************************

package Mail::POP3Client;

use strict;
use warnings;
use Carp;
use IO::Socket qw(SOCK_STREAM);

use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);

require Exporter;

@ISA = qw(Exporter);
# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.
@EXPORT = qw();

$VERSION = '2.21';


# Preloaded methods go here.

#******************************************************************************
#* constructor
#* new Mail::POP3Client( USER => user,
#*                       PASSWORD => pass,
#*                       HOST => host,
#*                       AUTH_MODE => [BEST|APOP|CRAM-MD5|PASS],
#*                       TIMEOUT => 30,
#*                       LOCALADDR => 'xxx.xxx.xxx.xxx[:xx]',
#*                       DEBUG => 1 );
#* OR (deprecated)
#* new Mail::POP3Client( user, pass, host [, port, debug, auth_mode, local_addr])
#******************************************************************************
sub new
{
  my $classname = shift;
  my $self = {
	      DEBUG => 0,
	      SERVER => "pop3",
	      PORT => 110,
	      COUNT => -1,
	      SIZE => -1,
	      ADDR => "",
	      STATE => 'DEAD',
	      MESG => 'OK',
	      BANNER => '',
	      MESG_ID => '',
	      AUTH_MODE => 'BEST',
	      EOL => "\015\012",
	      TIMEOUT => 60,
	      STRIPCR => 0,
	      LOCALADDR => undef,
	      SOCKET => undef,
	      USESSL => 0,
	     };
  $self->{tranlog} = ();
  $^O =~ /MacOS/i && ($self->{STRIPCR} = 1);
  bless( $self, $classname );
  $self->_init( @_ );

  if ( defined($self->User()) && defined($self->Pass()) )
    {
      $self->Connect();
    }

  return $self;
}



#******************************************************************************
#* initialize - check for old-style params
#******************************************************************************
sub _init {
  my $self = shift;

  # if it looks like a hash
  if ( @_ && (scalar( @_ ) % 2 == 0) )
    {
      # ... and smells like a hash...
      my %hashargs = @_;
      if ( ( defined($hashargs{USER}) &&
	     defined($hashargs{PASSWORD}) ) ||
	   defined($hashargs{HOST})
	 )
	{
	  # ... then it must be a hash!  Push all values into my internal hash.
	  foreach my $key ( keys %hashargs )
	    {
	      $self->{$key} = $hashargs{$key};
	    }
	}
      else {$self->_initOldStyle( @_ );}
    }
  else {$self->_initOldStyle( @_ );}
}

#******************************************************************************
#* initialize using the old positional parameter style new - deprecated
#******************************************************************************
sub _initOldStyle {
  my $self = shift;
  $self->User( shift );
  $self->Pass( shift );
  my $host = shift;
  $host && $self->Host( $host );
  my $port = shift;
  $port && $self->Port( $port );
  my $debug = shift;
  $debug && $self->Debug( $debug );
  my $auth_mode = shift;
  $auth_mode && ($self->{AUTH_MODE} = $auth_mode);
  my $localaddr = shift;
  $localaddr && ($self->{LOCALADDR} = $localaddr);
}

#******************************************************************************
#* What version are we?
#******************************************************************************
sub Version {
  return $VERSION;
}


#******************************************************************************
#* Is the socket alive?
#******************************************************************************
sub Alive
{
  my $me = shift;
  $me->State =~ /^AUTHORIZATION$|^TRANSACTION$/i;
} # end Alive


#******************************************************************************
#* What's the frequency Kenneth?
#******************************************************************************
sub State
{
  my $me = shift;
  my $stat = shift or return $me->{STATE};
  $me->{STATE} = $stat;
} # end Stat


#******************************************************************************
#* Got anything to say?
#******************************************************************************
sub Message
{
  my $me = shift;
  my $msg = shift or return $me->{MESG};
  $me->{MESG} = $msg;
} # end Message


#******************************************************************************
#* set/query debugging
#******************************************************************************
sub Debug
{
  my $me = shift;
  my $debug = shift or return $me->{DEBUG};
  $me->{DEBUG} = $debug;

} # end Debug


#******************************************************************************
#* set/query the port number
#******************************************************************************
sub Port
{
  my $me = shift;
  my $port = shift or return $me->{PORT};

  $me->{PORT} = $port;

} # end port


#******************************************************************************
#* set the host
#******************************************************************************
sub Host
{
  my $me = shift;
  my $host = shift or return $me->{HOST};

#  $me->{INTERNET_ADDR} = inet_aton( $host ) or
#    $me->Message( "Could not inet_aton: $host, $!") and return;
  $me->{HOST} = $host;
} # end host

#******************************************************************************
#* set the local address
#******************************************************************************
sub LocalAddr
{
  my $me = shift;
  my $addr = shift or return $me->{LOCALADDR};

  $me->{LOCALADDR} = $addr;
}


#******************************************************************************
#* query the socket to use as a file handle - allows you to set the
#* socket too to allow SSL (thanks to Jamie LeTual)
#******************************************************************************
sub Socket {
  my $me = shift;
  my $socket = shift or return $me->{'SOCKET'};
  $me->{'SOCKET'} = $socket;
}

sub AuthMode {
  my $me = shift;
  my $mode = shift;
  return $me->{'AUTH_MODE'} unless $mode;
  $me->{'AUTH_MODE'} = $mode;
}

#******************************************************************************
#* set/query the USER
#******************************************************************************
sub User
{
  my $me = shift;
  my $user = shift or return $me->{USER};
  $me->{USER} = $user;

} # end User


#******************************************************************************
#* set/query the password
#******************************************************************************
sub Pass
{
  my $me = shift;
  my $pass = shift or return $me->{PASSWORD};
  $me->{PASSWORD} = $pass;

} # end Pass

sub Password { Pass(@_); }

#******************************************************************************
#*
#******************************************************************************
sub Count
{
  my $me = shift;
  my $c = shift;
  if (defined $c and length($c) > 0) {
    $me->{COUNT} = $c;
  } else {
    return $me->{COUNT};
  }

} # end Count


#******************************************************************************
#* set/query the size of the mailbox
#******************************************************************************
sub Size
{
  my $me = shift;
  my $c = shift;
  if (defined $c and length($c) > 0) {
    $me->{SIZE} = $c;
  } else {
    return $me->{SIZE};
  }

} # end Size


#******************************************************************************
#*
#******************************************************************************
sub EOL {
  my $me = shift;
  return $me->{'EOL'};
}


#******************************************************************************
#*
#******************************************************************************
sub Close
{
  my $me = shift;

  # only send the QUIT message is the socket is still connected.  Some
  # POP3 servers close the socket after a failed authentication.  It
  # is unclear whether the RFC allows this or not, so we'll attempt to
  # check the condition of the socket before sending data here.
  if ($me->Alive() && $me->Socket() && $me->Socket()->connected() ) {
    $me->_sockprint( "QUIT", $me->EOL );

    # from Patrick Bourdon - need this because some servers do not
    # delete in all cases.  RFC says server can respond (in UPDATE
    # state only, otherwise always OK).
    my $line = $me->_sockread();
    unless (defined $line) {
	$me->Message("Socket read failed for QUIT");
	# XXX: Should add the following?
	#$me->State('DEAD');
	undef $me->{SOCKET};
	return 0;
    }
    $me->Message( $line );
    close( $me->Socket() ) or $me->Message("close failed: $!") and do {
      undef $me->{SOCKET};
      return 0;
    };
    $me->State('DEAD');
    undef $me->{SOCKET};
    $line =~ /^\+OK/i || return 0;
  }
  1;
} # end Close

sub close { Close(@_); }
sub logout { Close(@_); }

#******************************************************************************
#*
#******************************************************************************
sub DESTROY
{
  my $me = shift;
  $me->Close;
} # end DESTROY


#******************************************************************************
#* Connect to the specified POP server
#******************************************************************************
sub Connect
{
  my ($me, $host, $port) = @_;

  $host and $me->Host($host);
  $port and $me->Port($port);

  $me->Close();

  my $s = $me->{SOCKET};
  $s || do {
    if ( $me->{USESSL} ) {
      if ( $me->Port() == 110 ) { $me->Port( 995 ); }
        eval {
	  require IO::Socket::SSL;
	};
      $@ and $me->Message("Could not load IO::Socket::SSL: $@") and return 0;
      $s = IO::Socket::SSL->new( PeerAddr => $me->Host(),
				 PeerPort => $me->Port(),
				 Proto    => "tcp",
				 Type      => SOCK_STREAM,
				 LocalAddr => $me->LocalAddr(),
				 Timeout   => $me->{TIMEOUT} )
	or $me->Message( "could not connect SSL socket [$me->{HOST}, $me->{PORT}]: $!" )
	  and return 0;
      $me->{SOCKET} = $s;

    } else {
      $s = IO::Socket::INET->new( PeerAddr  => $me->Host(),
				  PeerPort  => $me->Port(),
				  Proto     => "tcp",
				  Type      => SOCK_STREAM,
				  LocalAddr => $me->LocalAddr(),
				  Timeout   => $me->{TIMEOUT} )
	or
	  $me->Message( "could not connect socket [$me->{HOST}, $me->{PORT}]: $!" )
	    and
	      return 0;
      $me->{SOCKET} = $s;
    }
  };

  $s->autoflush( 1 );

  defined(my $msg = $me->_sockread()) or $me->Message("Could not read") and return 0;
  chomp $msg;
  $me->{BANNER}= $msg;

  # add check for servers that return -ERR on connect (not in RFC1939)
  $me->Message($msg);
  $msg =~ /^\+OK/i || return 0;

  my $atom = qr([-_\w!#$%&'*+/=?^`{|}~]+);
  $me->{MESG_ID}= $1 if ($msg =~/(<$atom(?:\.$atom)*\@$atom(?:\.$atom)*>)/o);
  $me->Message($msg);

  $me->State('AUTHORIZATION');
  defined($me->User()) and defined($me->Pass()) and $me->Login();

} # end Connect

sub connect { Connect(@_); }

#******************************************************************************
#* login to the POP server. If the AUTH_MODE is set to BEST, and the server
#* appears to support APOP, it will try APOP, if that fails, then it will try
#* SASL CRAM-MD5 if the server appears to support it, and finally PASS.
#* If the AUTH_MODE is set to APOP, and the server appears to support APOP, it
#* will use APOP or it will fail to log in. Likewise, for AUTH_MODE CRAM-MD5,
#* no PASS-fallback is made. Otherwise password is sent in clear text.
#******************************************************************************
sub Login
{
  my $me= shift;
  return 1 if $me->State eq 'TRANSACTION';  # Already logged in

  if ($me->{AUTH_MODE} eq 'BEST') {
    my $retval;
    if ($me->{MESG_ID}) {
      $retval = $me->Login_APOP();
      return($retval) if ($me->State eq 'TRANSACTION');
    }
    my $has_cram_md5 = 0;
    foreach my $capa ($me->Capa()) {
      $capa =~ /^SASL.*?\sCRAM-MD5\b/ and $has_cram_md5 = 1 and last;
    }
    if ($has_cram_md5) {
      $retval = $me->Login_CRAM_MD5();
      return($retval) if ($me->State() eq 'TRANSACTION');
    }
  }
  elsif ($me->{AUTH_MODE} eq 'APOP') {
    return(0) if (!$me->{MESG_ID});   # fail if the server does not support APOP
    return($me->Login_APOP());
  }
  elsif ($me->{AUTH_MODE} eq 'CRAM-MD5') {
    return($me->Login_CRAM_MD5());
  }
  elsif ($me->{AUTH_MODE} ne 'PASS') {
    $me->Message("Programing error. AUTH_MODE (".$me->{AUTH_MODE}.") not BEST | APOP | CRAM-MD5 | PASS.");
    return(0);
  }
  return($me->Login_Pass());
}

sub login { Login(@_); }

#******************************************************************************
#* login to the POP server using APOP (md5) authentication.
#******************************************************************************
sub Login_APOP
{
  my $me = shift;
  eval {
    require Digest::MD5;
  };
  $@ and $me->Message("APOP failed: $@") and return 0;

  my $hash = Digest::MD5::md5_hex($me->{MESG_ID} . $me->Pass());

  $me->_checkstate('AUTHORIZATION', 'APOP') or return 0;
  $me->_sockprint( "APOP " , $me->User , ' ', $hash, $me->EOL );
  my $line = $me->_sockread();
  unless (defined $line) {
      $me->Message("Socket read failed for APOP");
      $me->State('AUTHORIZATION');
      return 0;
  }
  chomp $line;
  $me->Message($line);
  # some servers will close here...
  $me->NOOP() || do {
    $me->State('DEAD');
    undef $me->{SOCKET};
    $me->Message("APOP failed: server has closed the socket");
    return 0;
  };

  $line =~ /^\+OK/ or $me->Message("APOP failed: $line") and return 0;
  $me->State('TRANSACTION');

  $me->POPStat() or return 0;
}


#******************************************************************************
#* login to the POP server using CRAM-MD5 (RFC 2195) authentication.
#******************************************************************************
sub Login_CRAM_MD5
{
  my $me = shift;

  eval {
    require Digest::HMAC_MD5;
    require MIME::Base64;
  };
  $@ and $me->Message("AUTH CRAM-MD5 failed: $@") and return 0;

  $me->_checkstate('AUTHORIZATION', 'AUTH') or return 0;
  $me->_sockprint('AUTH CRAM-MD5', $me->EOL());
  my $line = $me->_sockread();
  chomp $line;
  $me->Message($line);

  if ($line =~ /^\+ (.+)$/) {

    my $hmac =
      Digest::HMAC_MD5::hmac_md5_hex(MIME::Base64::decode($1), $me->Pass());
    (my $response = MIME::Base64::encode($me->User() . " $hmac")) =~ s/[\r\n]//g;
    $me->_sockprint($response, $me->EOL());

    $line = $me->_sockread();
    chomp $line;
    $me->Message($line);
    $line =~ /^\+OK/ or
      $me->Message("AUTH CRAM-MD5 failed: $line") and return 0;

  } else {
    $me->Message("AUTH CRAM-MD5 failed: $line") and return 0;
  }

  $me->State('TRANSACTION');

  $me->POPStat() or return 0;
}


#******************************************************************************
#* login to the POP server using simple (cleartext) authentication.
#******************************************************************************
sub Login_Pass
{
  my $me = shift;

  $me->_checkstate('AUTHORIZATION', 'USER') or return 0;
  $me->_sockprint( "USER " , $me->User() , $me->EOL );
  my $line = $me->_sockread();
  unless (defined $line) {
      $me->Message("Socket read failed for USER");
      $me->State('AUTHORIZATION');
      return 0;
  }
  chomp $line;
  $me->Message($line);
  $line =~ /^\+/ or $me->Message("USER failed: $line") and $me->State('AUTHORIZATION')
    and return 0;

  $me->_sockprint( "PASS " , $me->Pass() , $me->EOL );
  $line = $me->_sockread();
  unless (defined $line) {
      $me->Message("Socket read failed for PASS");
      $me->State('AUTHORIZATION');
      return 0;
  }
  chomp $line;
  $me->Message($line);
  $line =~ /^\+OK/ or $me->Message("PASS failed: $line") and $me->State('AUTHORIZATION')
    and return 0;

  $me->State('TRANSACTION');

  ($me->POPStat() >= 0) or return 0;

} # end Login


#******************************************************************************
#* Get the Head of a message number.  If you give an optional number
#* of lines you will get the first n lines of the body also.  This
#* allows you to preview a message.
#******************************************************************************
sub Head
{
  my $me = shift;
  my $num = shift;
  my $lines = shift;
  $lines ||= 0;
  $lines =~ /\d+/ || ($lines = 0);

  my $header = '';

  $me->_checkstate('TRANSACTION', 'TOP') or return;
  $me->_sockprint( "TOP $num $lines", $me->EOL );
  my $line = $me->_sockread();
  unless (defined $line) {
      $me->Message("Socket read failed for TOP");
      return;
  }
  chomp $line;
  $line =~ /^\+OK/ or $me->Message("Bad return from TOP: $line") and return;
  $line =~ /^\+OK (\d+) / and my $buflen = $1;

  while (1) {
    $line = $me->_sockread();
    unless (defined $line) {
	$me->Message("Socket read failed for TOP");
	return;
    }
    last if $line =~ /^\.\s*$/;
    $line =~ s/^\.\././;
    $header .= $line;
  }

  return wantarray ? split(/\r?\n/, $header) : $header;
} # end Head


#******************************************************************************
#* Get the header and body of a message
#******************************************************************************
sub HeadAndBody
{
  my $me = shift;
  my $num = shift;
  my $mandb = '';

  $me->_checkstate('TRANSACTION', 'RETR') or return;
  $me->_sockprint( "RETR $num", $me->EOL );
  my $line = $me->_sockread();
  unless (defined $line) {
      $me->Message("Socket read failed for RETR");
      return;
  }
  chomp $line;
  $line =~ /^\+OK/ or $me->Message("Bad return from RETR: $line") and return;
  $line =~ /^\+OK (\d+) / and my $buflen = $1;

  while (1) {
    $line = $me->_sockread();
    unless (defined $line) {
	$me->Message("Socket read failed for RETR");
	return;
    }
    last if $line =~ /^\.\s*$/;
    # convert any '..' at the start of a line to '.'
    $line =~ s/^\.\././;
    $mandb .= $line;
  }

  return wantarray ? split(/\r?\n/, $mandb) : $mandb;

} # end HeadAndBody

sub message_string { HeadAndBody(@_); }

#******************************************************************************
#* get the head and body of a message and write it to a file handle.
#* Sends the raw data: does no CR/NL stripping or mapping.
#******************************************************************************
sub HeadAndBodyToFile
{
  local ($, , $\);
  my $me = shift;
  my $fh = shift;
  my $num = shift;
  my $body = '';

  $me->_checkstate('TRANSACTION', 'RETR') or return;
  $me->_sockprint( "RETR $num", $me->EOL );
  my $line = $me->_sockread();
  unless (defined $line) {
      $me->Message("Socket read failed for RETR");
      return 0;
  }
  chomp $line;
  $line =~ /^\+OK/ or $me->Message("Bad return from RETR: $line") and return 0;
  $line =~ /^\+OK (\d+) / and my $buflen = $1;

  while (1) {
    $line = $me->_sockread();
    unless (defined $line) {
	$me->Message("Socket read failed for RETR");
	return 0;
    }
    last if $line =~ /^\.\s*$/;
    # convert any '..' at the start of a line to '.'
    $line =~ s/^\.\././;
    print $fh $line;
  }
  return 1;
} # end BodyToFile



#******************************************************************************
#* get the body of a message
#******************************************************************************
sub Body
{
  my $me = shift;
  my $num = shift;
  my $body = '';

  $me->_checkstate('TRANSACTION', 'RETR') or return;
  $me->_sockprint( "RETR $num", $me->EOL );
  my $line = $me->_sockread();
  unless (defined $line) {
      $me->Message("Socket read failed for RETR");
      return;
  }
  chomp $line;
  $line =~ /^\+OK/ or $me->Message("Bad return from RETR: $line") and return;
  $line =~ /^\+OK (\d+) / and my $buflen = $1;

  # skip the header
  do {
    $line = $me->_sockread();
    unless (defined $line) {
	$me->Message("Socket read failed for RETR");
	return;
    }
    $line =~ s/[\r\n]//g;
  } until $line =~ /^(\s*|\.)$/;
  $line =~ /^\.\s*$/ && return;  # we found a header only!  Lotus Notes seems to do this.

  while (1) {
    $line = $me->_sockread();
    unless (defined $line) {
	$me->Message("Socket read failed for RETR");
	return;
    }
    last if $line =~ /^\.\s*$/;
    # convert any '..' at the start of a line to '.'
    $line =~ s/^\.\././;
    $body .= $line;
  }

  return wantarray ? split(/\r?\n/, $body) : $body;

} # end Body


#******************************************************************************
#* get the body of a message and write it to a file handle.  Sends the raw data:
#* does no CR/NL stripping or mapping.
#******************************************************************************
sub BodyToFile
{
  local ($, , $\);
  my $me = shift;
  my $fh = shift;
  my $num = shift;
  my $body = '';

  $me->_checkstate('TRANSACTION', 'RETR') or return;
  $me->_sockprint( "RETR $num", $me->EOL );
  my $line = $me->_sockread();
  unless (defined $line) {
      $me->Message("Socket read failed for RETR");
      return;
  }
  chomp $line;
  $line =~ /^\+OK/ or $me->Message("Bad return from RETR: $line") and return;
  $line =~ /^\+OK (\d+) / and my $buflen = $1;

  # skip the header
  do {
    $line = $me->_sockread();
    unless (defined $line) {
	$me->Message("Socket read failed for RETR");
	return;
    }
    $line =~ s/[\r\n]//g;
  } until $line =~ /^(\s*|\.)$/;
  $line =~ /^\.\s*$/ && return;  # we found a header only!  Lotus Notes seems to do this.

  while (1) {
    $line = $me->_sockread();
    unless (defined $line) {
	$me->Message("Socket read failed for RETR");
	return;
    }
    chomp $line;
    last if $line =~ /^\.\s*$/;
    # convert any '..' at the start of a line to '.'
    $line =~ s/^\.\././;
    print $fh $line, "\n";
  }
} # end BodyToFile



#******************************************************************************
#* handle a STAT command - returns the number of messages in the box
#******************************************************************************
sub POPStat
{
  my $me = shift;

  $me->_checkstate('TRANSACTION', 'STAT') or return -1;
  $me->_sockprint( "STAT", $me->EOL );
  my $line = $me->_sockread();
  unless (defined $line) {
      $me->Message("Socket read failed for STAT");
      return -1;
  }
  $line =~ /^\+OK/ or $me->Message("STAT failed: $line") and return -1;
  $line =~ /^\+OK (\d+) (\d+)/ and $me->Count($1), $me->Size($2);

  return $me->Count();
}


#******************************************************************************
#* issue the LIST command
#******************************************************************************
sub List {
  my $me = shift;
  my $num = shift || '';
  my $CMD = shift || 'LIST';
  $CMD=~ tr/a-z/A-Z/;

  $me->Alive() or return;

  my @retarray = ();
  my $ret = '';

  $me->_checkstate('TRANSACTION', $CMD) or return;
  $me->_sockprint($CMD, $num ? " $num" : '', $me->EOL());

  my $line = $me->_sockread();
  unless (defined $line) {
      $me->Message("Socket read failed for LIST");
      return;
  }
  $line =~ /^\+OK/ or $me->Message("$line") and return;
  if ($num) {
    $line =~ s/^\+OK\s*//;
    return $line;
  }
  while( defined( $line = $me->_sockread() ) ) {
    $line =~ /^\.\s*$/ and last;
    $ret .= $line;
    chomp $line;
    push(@retarray, $line);
  }
  if ($ret) {
    return wantarray ? @retarray : $ret;
  }
}

#******************************************************************************
#* issue the LIST command, but return results in an indexed array.
#******************************************************************************
sub ListArray {
  my $me = shift;
  my $num = shift || '';
  my $CMD = shift || 'LIST';
  $CMD=~ tr/a-z/A-Z/;

  $me->Alive() or return;

  my @retarray = ();
  my $ret = '';

  $me->_checkstate('TRANSACTION', $CMD) or return;
  $me->_sockprint($CMD, $num ? " $num" : '', $me->EOL());
  my $line = $me->_sockread();
  unless (defined $line) {
      $me->Message("Socket read failed for LIST");
      return;
  }
  $line =~ /^\+OK/ or $me->Message("$line") and return;
  if ($num) {
    $line =~ s/^\+OK\s*//;
    return $line;
  }
  while( defined( $line = $me->_sockread() ) ) {
    $line =~ /^\.\s*$/ and last;
    $ret .= $line;
    chomp $line;
    my ($num, $uidl) = split('\s+', $line);
    $retarray[$num] = $uidl;
  }
  if ($ret) {
    return wantarray ? @retarray : $ret;
  }
}


#******************************************************************************
#* retrieve the given message number - uses HeadAndBody
#******************************************************************************
sub Retrieve {
  return HeadAndBody( @_ );
}

#******************************************************************************
#* retrieve the given message number to the given file handle- uses
#* HeadAndBodyToFile
#******************************************************************************
sub RetrieveToFile {
  return HeadAndBodyToFile( @_ );
}


#******************************************************************************
#* implement the LAST command - see the rfc (1081) OBSOLETED by RFC
#******************************************************************************
sub Last
{
  my $me = shift;

  $me->_checkstate('TRANSACTION', 'LAST') or return;
  $me->_sockprint( "LAST", $me->EOL );
  my $line = $me->_sockread();
  unless (defined $line) {
      $me->Message("Socket read failed for LAST");
      return 0;
  }

  $line =~ /\+OK (\d+)\D*$/ and return $1;
}


#******************************************************************************
#* reset the deletion stat
#******************************************************************************
sub Reset
{
  my $me = shift;

  $me->_checkstate('TRANSACTION', 'RSET') or return;
  $me->_sockprint( "RSET", $me->EOL );
  my $line = $me->_sockread();
  unless (defined $line) {
      $me->Message("Socket read failed for RSET");
      return 0;
  }
  $line =~ /^\+OK/ and return 1;
  return 0;
}


#******************************************************************************
#* delete the given message number
#******************************************************************************
sub Delete {
  my $me = shift;
  my $num = shift || return;

  $me->_checkstate('TRANSACTION', 'DELE') or return;
  $me->_sockprint( "DELE $num",  $me->EOL );
  my $line = $me->_sockread();
  unless (defined $line) {
      $me->Message("Socket read failed for DELE");
      return 0;
  }
  $me->Message($line);
  $line =~ /^\+OK/ && return 1;
  return 0;
}

sub delete_message { Delete(@_); }

#******************************************************************************
#* UIDL - submitted by Dion Almaer ([e-mail])
#******************************************************************************
sub Uidl
{
  my $me = shift;
  my $num = shift || '';

  $me->Alive() or return;

  my @retarray = ();
  my $ret = '';

  $me->_checkstate('TRANSACTION', 'UIDL') or return;
  $me->_sockprint('UIDL', $num ? " $num" : '', $me->EOL());
  my $line = $me->_sockread();
  unless (defined $line) {
      $me->Message("Socket read failed for UIDL");
      return;
  }
  $line =~ /^\+OK/ or $me->Message($line) and return;
  if ($num) {
    $line =~ s/^\+OK\s*//;
    return $line;
  }
  while( defined( $line = $me->_sockread() ) ) {
    $line =~ /^\.\s*$/ and last;
    $ret .= $line;
    chomp $line;
    my ($num, $uidl) = split('\s+', $line);
    $retarray[$num] = $uidl;
  }
  if ($ret) {
    return wantarray ? @retarray : $ret;
  }
}


#******************************************************************************
#* CAPA - query server capabilities, see RFC 2449
#******************************************************************************
sub Capa {

  my $me = shift;

  # no state check here, all are allowed

  $me->Alive() or return;

  my @retarray = ();
  my $ret = '';

  $me->_sockprint('CAPA', $me->EOL());

  my $line = $me->_sockread();
  $line =~ /^\+OK/ or $me->Message($line) and return;

  while(defined($line = $me->_sockread())) {
    $line =~ /^\.\s*$/ and last;
    $ret .= $line;
    chomp $line;
    push(@retarray, $line);
  }

  if ($ret) {
    return wantarray ? @retarray : $ret;
  }
}

#******************************************************************************
#* XTND - submitted by Chris Moates ([e-mail])
#******************************************************************************
sub Xtnd {
  my $me = shift;
  my $xtndarg = shift || '';

  if ($xtndarg eq '') {
    $me->Message("XTND requires a string argument");
    return;
  }

  my $s = $me->Socket();
  $me->_checkstate('TRANSACTION', 'XTND') or return;
  $me->Alive() or return;

  $me->_sockprint( "XTND $xtndarg", $me->EOL );
  my $line = $me->_sockread();
  $line =~ /^\+OK/ or $me->Message($line) and return;
  $line =~ s/^\+OK\s*//;
  return $line;
}

#******************************************************************************
#* UTF8 - submitted by [e-mail]
#******************************************************************************
sub UTF8 {
  my $me = shift;
  if (grep { /^UTF8 USER/ } $me->Capa()) {
    # my $sock = $me->Socket(); # Is this needed? Xtnd() does it...
    if ($me->Alive()) {
       $me->_sockprint("UTF8" . $me->EOL());
       my $result = $me->_sockread();
       $result = s/\r?\n$//;
       $result =~ /^\+OK/ or $me->Message($result) and return;
       $result =~ s/^\+OK\s*//;
       $result ||= "[inferred: UTF-8 mode enabled]";
       return $result;
    }
  }
  return;
}

#******************************************************************************
#* NOOP - used to check socket
#******************************************************************************
sub NOOP {
  my $me = shift;

  my $s = $me->Socket();
  $me->Alive() or return 0;

  $me->_sockprint( "NOOP", $me->EOL );
  my $line = $me->_sockread();
#  defined( $line ) or return 0;
  $line =~ /^\+OK/ or return 0;
  return 1;
}


#******************************************************************************
#* Mail::IMAPClient compatibility functions ([e-mail])
#******************************************************************************

# Empty stubs
sub Peek {}
sub Uid {}

# Pop doesn't have concept of different folders
sub folders { return ('INBOX'); }
sub Folder { return ('INBOX'); }
sub select {}

# Message accessing
sub unseen {
    my $me = shift;
    my $count = $me->Count;
    return () if !$count;
    return ( 1..$count);
}

#*****************************************************************************
#* Check the state before issuing a command
#*****************************************************************************
sub _checkstate
{
  my ($me, $state, $cmd) = @_;
  my $currstate = $me->State();
  if ($currstate ne $state) {
    $me->Message("POP3 command $cmd may be given only in the '$state' state " .
                 "(current state is '$currstate').");
    return 0;
  } else {
    return 1;
  }
}


#*****************************************************************************
#* funnel all read/write through here to allow easier debugging
#* ([e-mail])
#*****************************************************************************
sub _sockprint
{
  local ($, , $\);
  my $me = shift;
  my $s = $me->Socket();
  $me->Debug and Carp::carp "POP3 -> ", @_;
  my $outline = "@_";
  chomp $outline;
  push(@{$me->{tranlog}}, $outline);
  print $s @_;
}

sub _sockread
{
  my $me = shift;
  my $line = $me->Socket()->getline();
  unless (defined $line) {
      return;
  }

  # Macs seem to leave CR's or LF's sitting on the socket.  This
  # removes them.
  $me->{STRIPCR} && ($line =~ s/^[\r]+//);

  $me->Debug and Carp::carp "POP3 <- ", $line;
  $line =~ /^[\\+\\-](OK|ERR)/i && do {
    my $l = $line;
    chomp $l;
    push(@{$me->{tranlog}}, $l);
  };
  return $line;
}


# end package Mail::POP3Client

# Autoload methods go after =cut, and are processed by the autosplit program.

1;
__END__