# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
#   GT::Mail::POP3
#   Author: Scott Beck
#   CVS Info : 087,071,086,086,085      
#   $Id: POP3.pm,v 1.57 2008/09/23 23:55:26 brewt Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc.  All Rights Reserved.
# ==================================================================
#
# Description: A general purpose perl interface to a POP3 server.
#

package GT::Mail::POP3;
# ==================================================================

# Pragmas
use strict;
use vars qw!$VERSION $DEBUG $ERROR $CRLF @ISA $ERRORS $ATTRIBS!;

# Constants
use constants TIMEOUT => 0.01; # The timeout used on selects.

# Internal modules
use GT::Base;
use GT::Socket::Client;
use GT::Mail::Parts;
use GT::Mail::Parse;

# System modules
use Fcntl qw/O_NONBLOCK F_SETFL F_GETFL/;
use POSIX qw/EAGAIN EINTR/;

# Silence warnings
$GT::Mail::Parse::error = '';

@ISA   = qw(GT::Base);
$DEBUG = 0;
$CRLF  = "\r\n";
$|     = 1;

$ATTRIBS = {
    host      => undef,
    port      => undef,
    user      => undef,
    pass      => undef,
    auth_mode => 'PASS',
    debug     => 0,
    blocking  => 0,
    ssl       => 0,
    timeout   => 30, # The connection timeout (passed to GT::Socket::Client)
    data_timeout => 5, # The timeout to read/write data from/to the connected socket
};

$ERRORS = {
    NOTCONNECTED => "You are calling %s and you have not connected yet!",
    CANTCONNECT  => "Could not connect to POP3 server: %s",
    READ         => "Unble to read from socket, reason (%s). Read: (%s)",
    WRITE        => "Unable to write %s length to socket. Wrote %s, Error(%s)",
    NOEOF        => "No EOF or EOL found. Socket locked.",
    ACTION       => "Could not %s. Server said: %s",
    NOMD5        => "Unable to load GT::MD5 (required for APOP authentication): %s",
    PARSE        => "An error occurred while parsing an email: %s",
    LOGIN        => "An error occurred while logging in: %s",
    OPEN         => "Could not open (%s) for read and write. Reason: %s",
};

sub head_part {
# --------------------------------------------------------
# my $head = $obj->head_part($num);
# ---------------------------------
#   This method takes one argument, the number message to
#   parse. It returns a GT::Mail::Parts object that has
#   only the top level head part parsed.
#
    my ($self, $num) = @_;
    $num and $num =~ /^\d+$/ or return $self->error("BADARGS", "FATAL", '$obj->head_part ($msg_num)');
    my $io = '';
    $self->top($num, sub { $io .= $_[0] }) or return;
    return GT::Mail::Parse->new(debug  => $self->{_debug}, crlf => $CRLF)->parse_head(\$io);
}

sub all_head_parts {
# --------------------------------------------------------
# my @heads = $obj->all_head_parts;
# ---------------------------------
#   This does much the same as head_part() but returns an
#   array of GT::Mail::Parts objects, each one only having
#   the head of the message parsed.
#
    my $self = shift;
    my @head_parts;
    for (1 .. $self->stat) {
        my $part = $self->head_part($_) or return;
        push(@head_parts, $part);
    }
    return wantarray ? @head_parts : \@head_parts;
}

sub parse_message {
# --------------------------------------------------------
# my $mail = $obj->parse_message($num);
# -------------------------------------
#   This method returns a GT::Mail object. It calles parse
#   for the message number specified before returning the
#   object. You can retrieve the different parts of the
#   message through the GT::Mail object. If this method
#   fails you should check $GT::Mail::error.
#
    my ($self, $num) = @_;
    $num and $num =~ /^\d+$/ or return $self->error("BADARGS", "FATAL", '$obj->parse_message($msg_num)');
    my $io = $self->retr($num) or return;
    my $parser = new GT::Mail::Parse(debug => $self->{_debug}, in_string => $io, crlf => $CRLF);
    $parser->parse or return $self->error("PARSE", "WARN", $GT::Mail::Parse::error);
    return $parser;
}

sub init {
# --------------------------------------------------------
# Initilize the POP box object.
#
    my $self = shift;

    $self->set(@_);

    for (qw/user pass host/) {
        (defined($self->{$_})) or return $self->error('BADARGS', 'FATAL', "CLASS->new(%ARGS); The '$_' key in the hash must exists");
    }
    $self->{_debug} = exists($self->{debug}) ? delete($self->{debug}) : $DEBUG;

# Can be either PASS or APOP depending on login type.
    $self->{auth_mode} ||= 'PASS';

    return $self;
}

sub send {
# --------------------------------------------------------
# Send a message to the server.
#
    my ($self, $msg) = @_;

    unless (defined $msg and length $msg) {
        $self->debug("Sending blank message!") if $self->{_debug};
        return;
    }

# Get the socket and end of line.
    my $s = $self->{sock};
    defined($s) and defined fileno($s) or return $self->error("NOTCONNECTED", "WARN", "send()");

# Print the message.
    $self->debug("--> $msg") if $self->{_debug};

    $s->write($msg . $CRLF);

    $self->getline(my $line) or return;

    $line =~ s/$CRLF//o if $line;
    $line ||= 'Nothing sent back';
    $self->{message} = $line;
    $self->debug("<-- $line") if $self->{_debug};

    return $line;
}

sub getline {
# --------------------------------------------------------
# Read a line of input from the server.
#
    my ($self) = @_;
    my $got_cr;
    my $safety;
    my $s = $self->{sock};
    $s->readline($_[1]);
    return 1;
}

sub getall {
# --------------------------------------------------------
# Get all pending output from the server.
#
    my ($self) = @_;
    $_[1] = '';
    my $l = 0;
    my $safety;
    my $s = $self->{sock};
    if ($self->{blocking}) {
        while (<$s>) {
            last if /^\.$CRLF/o;
            s/^\.//; # Lines starting with a . are doubled up in POP3
            $_[1] .= $_;
        }
    }
    else {
        my $save = $s->read_size;
        $s->read_size(1048576);
        $s->readalluntil("\n.$CRLF", $_[1], ".$CRLF");
        $s->read_size($save);

        $_[1] =~ s/\n\.\r?\n$/\n/; # Remove the final . at the end of the e-mail
        $_[1] =~ s/^\.//mg; # Remove the initial '.' from any lines beginning with .
    }
    return 1;
}

sub connect {
# --------------------------------------------------------
# Connect to the server.
#
    my $self = shift;
    my ($s, $iaddr, $msg, $paddr, $proto);

    $self->debug("Attempting to connect .. ") if ($self->{_debug});

    $self->{blocking} = 1 if $self->{ssl};
    $self->{port} ||= $self->{ssl} ? 995 : 110;

# If there was an existing connection, it'll be closed here when we reassign
    $self->{sock} = GT::Socket::Client->open(
        port         => $self->{port},
        host         => $self->{host},
        max_down     => 0,
        timeout      => $self->{timeout},
        non_blocking => !$self->{blocking},
        select_time  => TIMEOUT,
        read_wait    => $self->{data_timeout},
        ssl          => $self->{ssl},
        debug        => $self->{_debug}
    ) or return $self->error("CANTCONNECT", "WARN", GT::Socket::Client->error);

    $self->debug('Connected to ' . $self->{host} . ' on port ' . $self->{port} . ($self->{ssl} ? ' via SSL' : '')) if $self->{_debug};

# Get server welcoming.
    $self->getline($msg) or return;

# Store this - it's needed for APOP authentication
    $self->{msg_id}= $1 if ($msg =~ /(<[\w\d\-\.]+\@[\w\d\-\.]+>)/);

    $self->debug("Going to login") if $self->{_debug};
    return $self->login();
}

sub login {
# --------------------------------------------------------
# Login either using APOP or regular.
#
    my $self = shift;
    ($self->{auth_mode} eq 'APOP' && $self->{msg_id}) ? $self->login_apop : $self->login_pass;
}

sub login_apop {
# --------------------------------------------------------
# Login using APOP.
#
    my $self = shift;
    my ($hash, $count, $line);
    {
        local $SIG{__DIE__};
        eval { require GT::MD5; 1 } or return $self->error('NOMD5', 'WARN', $@);
    }
    $self->debug("Attempting to log in via APOP ... ") if $self->{_debug};
    $hash = GT::MD5::md5_hex($self->{msg_id} . $self->{pass});

    local ($_) = $self->send('APOP ' . $self->{user} . ' ' . $hash) or return;
    substr($_, 0, 1) eq '+' or return $self->error("LOGIN", "WARN", "APOP Login failed: $_");
    if (/^\+OK \S+ has (\d+) /i) {
        $self->{count} = $1;
    }
    elsif (uc substr($_, 0, 3) ne '+OK') {
        return $self->error('LOGIN', 'WARN', $_);
    }
    $self->{state} = 'TRANSACTION';
    $self->stat() or return;

    $self->debug("APOP Login successful.") if $self->{_debug};
    return (($self->{count} == 0) ? '0E0' : $self->{count});
}

sub login_pass {
# --------------------------------------------------------
# Login using clear text authentication.
#
    my $self = shift;
    my ($line);

    $self->debug("Attempting to log in via clear text ... ") if $self->{_debug};

# Enter username.
    local($_) = $self->send('USER ' . $self->{user}) or return;
    substr($_, 0, 1) eq '+' or return $self->error('LOGIN', 'WARN', "USER POP Login failed: $_");

# Enter password.
    $_ = $self->send('PASS ' . $self->{pass}) or return;
    substr($_, 0, 1) eq '+' or return $self->error('LOGIN', 'WARN', "PASS POP Login failed: $_");

# Ok, get total number of message, and pop box status.
    if (/^\+OK \S+ has (\d+) /i) {
        $self->{count} = $1;
    }
    elsif (uc substr($_, 0, 3) ne '+OK') {
        return $self->error('LOGIN', 'WARN', $_);
    }
    $self->stat() or return;

    $self->debug("Login successful.") if $self->{_debug};
    return $self->{count} == 0 ? '0E0' : $self->{count};
}

sub top {
# --------------------------------------------------------
# Get the header of a message and the next x lines (optional).
#
    my ($self, $num, $code)  = @_;
    defined($num) or return $self->error('BADARGS', 'FATAL', '$obj->head($msg_num);. No message number passed to head.');
    $self->debug("Getting head of message $num ... ") if $self->{_debug};

    local($_)  = $self->send("TOP $num 0") or return;
    uc substr($_, 0, 3) eq '+OK' or return $self->error("ACTION", "WARN", "TOP $num 0", "($_)");

    my ($tp, $header);
    $self->getall($header);
    if (substr($header, 0, 1) eq '>') {
        substr($header, 0, index($header, $CRLF) + 2) = '';
    }

# Support broken headers which given unix linefeeds.
    if ($header =~ /[^\r]\n/) {
        $header =~ s/\r?\n/$CRLF/g;
    }
    $self->debug("Top of message $num retrieved.") if $self->{_debug};
    if ($code and ref $code eq 'CODE') {
        $code->($header);
    }
    else {
        return wantarray ? split(/$CRLF/o, $header) : $header;
    }

    return 1;
}

sub retr {
# --------------------------------------------------------
# Get the entire message.
#
    my ($self, $num, $code) = @_;
    defined($num) or return $self->error('BADARGS', 'FATAL', '$obj->retr ($msg_numm, $code);');

    $self->debug("Getting message $num ... ") if ($self->{_debug});

# Get the size of the message
    local ($_) = $self->send("RETR $num") or return;
    uc substr($_, 0, 3) eq '+OK' or return $self->error('ACTION', 'WARN', "RETR $num", $_);

# Retrieve the entire email
    my $body = '';
    $self->getall($body);

# Qmail puts this wierd header as the first line
    if (substr($body, 0, 1) eq '>') {
        substr($body, 0, index($body, $CRLF) + 2) = '';
    }

# Support broken pop servers that send us unix linefeeds.
    if ($body =~ /[^\r]\n/) {
        $body =~ s/\r?\n/$CRLF/g;
    }
    $self->debug("Message $num retrieved.") if $self->{_debug};
    if ($code and ref $code eq 'CODE') {
        $code->($body);
    }
    else {
        return \$body;
    }
    return 1;
}

sub last {
    my ($self) = @_;

    local($_) = $self->send("LAST") or return;
    uc substr($_, 0, 3) eq '+OK' or return $self->error("ACTION", "WARN", "LAST", $_);
    s/^\+OK\s*//i;
    return $_;
}

sub message_save {
# --------------------------------------------------------
# Get a message and save it to a file rather then returning.
#
    my ($self, $num, $file) = @_;

# Check arguments.
    $num  or return $self->error("BADARGS", "FATAL", '$obj->message_save ($msg_num, $IO);');
    $file or return $self->error("BADARGS", "FATAL", '$obj->message_save ($msg_num, $IO);');

    my $io;
    if (ref $file) {
        $io = $file;
    }
    else {
        $file =~ /^\s*(.+?)\s*$/ and $file = $1;
        $io = \do { local *FH; *FH };
        open $io, ">$file" or return $self->error("OPENWRITE", "FATAL", $file, "$!");
    }

# Get the entire message body.
    $self->retr($num, sub { print $io $_[0] });
    $self->debug("Message $num saved to '$file'.") if $self->{_debug};
    return 1;
}

sub stat {
# --------------------------------------------------------
# Handle a stat command, get the number of messages and size.
#
    my $self = shift;

    local($_) = $self->send("STAT") or return;
    uc substr($_, 0, 3) eq '+OK' or return $self->error('ACTION', 'WARN', 'STAT', $_);
    if (/^\+OK (\d+) (\d+)/i) {
        $self->{count} = $1;
        $self->{size}  = $2;
        $self->debug("STAT successful - count: $1 size: $2") if $self->{_debug};
    }
    else {
        $self->debug("STAT failed, can't determine count.") if $self->{_debug};
    }
    return $self->{count} || "0E0";
}

sub list {
# --------------------------------------------------------
# Return a list of messages available.
#
    my $self = shift;
    my $num  = shift || '';
    my @messages;

# Broken pop servers that don't like 'LIST '.
    my $cmd = ($num eq '') ? 'LIST' : "LIST $num";

    local($_) = $self->send($cmd) or return;
    uc substr($_, 0, 3) eq '+OK' or return $self->error("ACTION", "WARN", "LIST $num", $_);
    if ($num) {
        s/^\+OK\s*//i;
        return $_;
    }
    my $msg = '';
    $self->getall($msg);
    @messages = split /$CRLF/o => $msg;
    $self->debug(@messages . " messages listed.") if ($self->{_debug});
    if (@messages) {
        return wantarray ? @messages : join("", @messages);
    }
}

sub rset {
# --------------------------------------------------------
# Reset deletion stat.
#
    my $self = shift;
    local($_) = $self->send("RSET") or return;
    uc substr($_, 0, 3) eq '+OK' or return $self->error("ACTION", "WARN", "RSET", $_);
    return 1;
}

sub dele {
# --------------------------------------------------------
# Delete a given message.
#
    my ($self, $num)  = @_;
    $num and $num =~ /^\d+$/ or return $self->error("BADARGS", "FATAL", '$obj->dele ($msg_num)');
    local($_) = $self->send("DELE $num") or return;
    uc substr($_, 0, 3) eq '+OK' or return $self->error("ACTION", "WARN", "DELE $num", $_);
    return 1;
}

sub quit {
# --------------------------------------------------------
# Close the socket.
#
    my $self = shift;
    $self->send("QUIT") or return;
    close $self->{sock};
    $self->{sock} = undef;
    return 1;
}

sub uidl {
# --------------------------------------------------------
# Returns a list of uidls from the remote server
#
    my $self = shift;
    my $num  = shift;
    local $_;
    if ($num and !ref $num) {
        $_ = $self->send("UIDL $num") or return;
        /^\+OK \d+ (.+)$/i or return $self->error("ACTION", "WARN", "UIDL $num", $_);
        return $1;
    }
    my $ret = {};
    $_ = $self->send("UIDL") or return;
    uc substr($_, 0, 3) eq '+OK' or return $self->error("ACTION", "WARN", "UIDL $num", $_);
    my $list = '';
    $self->getall($list);
    for (split /$CRLF/o => $list) {
        if ($num and ref($num) eq 'CODE') {
            $num->($_);
        }
        else {
            /^(\d+) (.+)/ and $ret->{$1} = $2;
        }
    }
    return wantarray ? %{$ret} : $ret;
}

sub count {
# --------------------------------------------------------
# Accessor for number of messages waiting.
#
    return $_[0]->{count};
}

sub size {
# --------------------------------------------------------
# Accessor for size of messages waiting.
#
    return $_[0]->{count};
}

sub last_message {
# --------------------------------------------------------
# Accessor for last server message.

    @_ == 2 and $_[0]->{message} = $_[1];
    return $_[0]->{message};
}

sub DESTROY {
# --------------------------------------------------------
# Auto close the socket.
#
    my $self = shift;
    if ($self->{sock} and defined fileno($self->{sock})) {
        $self->send("QUIT");
        close $self->{sock};
        $self->{sock} = undef;
    }
    $self->debug("POP Object destroyed.") if ($self->{_debug} > 1);
}

1;

__END__

=head1 NAME

GT::Mail::POP3 - Receieve email through POP3 protocal

=head1 SYNOPSIS

    use GT::Mail::POP3;

    my $pop = GT::Mail::POP3->new(
        host      => 'mail.gossamer-threads.com',
        port      => 110,
        user      => 'someusername',
        pass      => 'somepassword',
        auth_mode => 'PASS',
        timeout   => 30,
        debug     => 1
    );

    my $count = $pop->connect or die $GT::Mail::POP3::error;

    for my $num (1 .. $count) {
        my $top = $pop->parse_head($num);

        my @to = $top->split_field;

        if (grep /myfriend\@gossamer-threads\.com/, @to) {
            $pop->message_save($num, '/keep/email.txt');
            last;
        }
    }

=head1 DESCRIPTION

GT::Mail::POP3 is a module to check an email account using the POP3 protocol.
Many of the methods are integrated with L<GT::Mail::Parse>.

=head2 new - constructor method

This method is inherited from L<GT::Base>. The argument to this method can be
in the form of a hash or hash ref. As a minimum 'user', 'pass', and 'host' must
be specified.

=over 4

=item debug

Sets the debugging level for this instance of GT::Mail::POP3.

=item host

Sets the host to connect to for checking a POP account. This argument must be
provided.

=item port

Sets the port on the POP server to attempt to connect to. This defaults to 110,
unless using SSL, for which the default is 995.

=item ssl

Establishes the connection using SSL.  Note that this requires Net::SSLeay of
at least version 1.06.

=item user

Sets the user name to login with when connecting to the POP server. This must
be specified.

=item pass

Sets the password to login with when connection to the POP server. This must be
specified.

=item auth_mode

Sets the authentication type for this connection. This can be one of two
values.  PASS (the default) or APOP. If set to APOP, GT::Mail::POP3 will use
APOP to login to the remote server.

=item timeout

Sets the connection timeout.  This isn't entirely reliable as it uses alarm(),
which isn't supported on all systems.  That aside, this normally isn't needed
if you want a timeout - it defaults to 30 on alarm()-supporting systems.  The
main purpose is to provide a value of 0 to disable the alarm() timeout.

=back

=head2 connect - Connect to the POP account

    $obj->connect or die $GT::Mail::POP3::error;

This method performs the connection to the POP server. Returns the count of
messages on the server on success, and undefined on failure. Takes no arguments
and called before you can perform any actions on the POP server.

=head2 head_part - Access the email header

    # Get a parsed header part object for the first email in the list.
    my $top_part = $obj->head_part(1);

Instance method. The only argument to this method is the message number to get.
Returns a L<GT::Mail::Parts> object containing only the parsed header of the
specified message.

=head2 all_head_parts - Access all email headers

    # Get all the head parts from all messages
    my @headers = $obj->all_head_parts;

Instance method. Gets all the headers of all the email's on the remote server.
Returns an array of the L<GT::Mail::Parts> object. One object for each
email. None of the email's bodies are retrieved, only the head.

=head2 parse_message - Access an email

    # Parse an email and get the GT::Mail object
    my $mail = $obj->parse_message (1);

Instance method. Pass in the number of the email to retrieve. This method
retrieves the specified email and returns the parsed GT::Mail object. If this
method fails you should check $GT::Mail::error for the error message.

=head2 message_save - Save an email

    open FH, '/path/to/email.txt' or die $!;

    # Save message 2 to file
    $obj->message_save (2, \*FH);
    close FH;

- or -

    $obj->message_save (2, '/path/to/email.txt') or die $GT::Mail::POP3::error;

Instance method. This method takes the message number as it's first argument,
and either a file path or a file handle ref as it's second argument. If a file
path is provided the file will be opened to truncate. The email is then
retrieved from the server and written to the file.

=head2 stat - Do a STAT command

    # Get the number of messages on the server
    my $count = $obj->stat;

Instance method. Does a STAT command on the remote server. It stores the total
size and returns the count of messages on the server, if successful. Otherwise
returns undef.

=head2 list - Do a LIST command

    # At a list of messages on the server
    my @messages = $obj->list;

Instance method. Does a LIST command on the remote server. Returns an array of
the lines in list context and a single scalar that contains all the lines in
scalar context.

=head2 rset - Do an RSET command

    # Tell the server to ignore any dele commands we have issued in this
    # session
    $obj->rset;

Instance method. Does an RSET command. This command resets the servers
knowledge of what should be deleted when QUIT is called. Returns 1 on success.

=head2 dele - Do a DELE command

    # Delete message 4
    $obj->dele (4);

Instance method. Does a DELE command. The only argument is the message number
to delete.  Returns 1 on success.

=head2 quit - Quit the connection

    # Close our connection
    $obj->quit;

Instance method. Sends the QUIT command to the server. The should should
disconnect soon after this. No more actions can be taken on this connection
until connect is called again.

=head2 uidl - Do a UIDL command

    # Get the uidl for message 1
    my $uidl = $obj->uidl (1);

    # Get a list of all the uidl's and print them
    $obj->uidl (sub { print @_ });

    # Get an array of all the uidl's
    my @uidl = $obj->uidl;

Instance method. Attempts to do a UIDL command on the remote server. Please be
aware support for the UIDL command is not very wide spread. This method can
take the message number as it's first argument. If the message number is given,
the UIDL for that message is returned. If the first argument is a code
reference, a UIDL command is done with no message specified and the code
reference is called for each line returned from the remote server. If no second
argument is given, a UIDL command is done, and the results are returned in a
has of message number to UIDL.

=head2 count - Get the number of messages

    # Get the count from the last STAT
    my $count = $obj->count;

This method returns the number of messages on the server from the last STAT
command. A STAT is done on connect.

=head2 size - Get the size of all messages

    # Get the total size of all messages on the server
    my $size = $obj->size;

This method returns the size of all messages in the server as returned by the
last STAT command sent to the server.

=head2 send - Send a raw command

    # Send a raw command to the server
    my $ret = $obj->send ("HELO");

This method sends the specified raw command to the POP server. The one line
return from the server is returned. Do not call this method if you are
expecting more than a one line response.

=head2 top - Retrieve the header

    # Get the header of message 2 in an array.  New lines are stripped
    my @header = $obj->top (2);

    # Get the header as a string
    my $header = $obj->top (2);

Instance method to retrieve the top of an email on the POP server. The only
argument should be the message number to retrieve. Returns a scalar containing
the header in scalar context and an array, which is the scalar split on
\015?\012, in list context.

=head2 retr - Retrieve an email

    # Get message 3 from the remote server in an array.  New lines are stripped
    my @email = $obj->retr (3);

    # Get it as a string
    my $email = $obj->retr (3);

Instance method to retrieve an email from the POP server. The first argument to
this method should be the message number to retrieve. The second argument is an
optional code ref to call for each line of the message that is retrieved. If no
code ref is specified, this method will put the email in a scalar and return
the scalar in scalar context and return the scalar split on \015?\012 in list
context.

=head1 REQUIREMENTS

L<GT::Socket::Client>
L<GT::Base>
L<GT::MD5> (for APOP authentication)

=head1 COPYRIGHT

Copyright (c) 2004 Gossamer Threads Inc.  All Rights Reserved.
http://www.gossamer-threads.com/

=head1 VERSION

Revision: $Id: POP3.pm,v 1.57 2008/09/23 23:55:26 brewt Exp $