# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
#   GT::Mail::BulkMail
#   Author: Jason Rhinelander
#   CVS Info : 087,071,086,086,085      
#   $Id: BulkMail.pm,v 1.51 2008/01/23 07:27:00 brewt Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc.  All Rights Reserved.
# ==================================================================
#
# Description: A simple bulk e-mail module to interface with either
#              sendmail or SMTP.
#
# ==================================================================

package GT::Mail::BulkMail;

use Exporter;
use GT::Base;
use GT::Socket::Client;
use GT::Mail::Encoder;
use constants CRLF => "\015\012", CR => "\015", LF => "\012";
use strict;
use GT::AutoLoader;
use vars qw(@ISA $VERSION $AUTOLOAD @EXPORT_OK %EXPORT_TAGS $VALID_HOST $CRLF $CR $LF $noIPCOpen2);

eval "use IPC::Open2";
$noIPCOpen2++ if $@;

@ISA = qw(Exporter);

@EXPORT_OK = qw(RFC822_date quoted_printable quote_name unquote_name
                $VALID_HOST CR LF CRLF $CR $LF $CRLF);

%EXPORT_TAGS = (
    quoting => [ qw/quoted_printable quote_name unquote_name/ ],
    crlf    => [ qw/CR LF CRLF $CR $LF $CRLF/ ],
);

$VERSION = sprintf "%d.%03d", q$Revision: 1.51 $ =~ /(\d+)\.(\d+)/;

$VALID_HOST = '(?:[a-zA-Z0-9][a-zA-Z0-9-]*(?:\.[a-zA-Z0-9][a-zA-Z0-9-]*)*)';

$CR = CR;
$LF = LF;
$CRLF = CRLF;

sub DESTROY {
    my $self = shift;
    $self->_smtp_disconnect();# if $self->{smtp_connected};
    $self->_sendmail_disconnect();# if $self->{sendmail_connected};
}

sub new {
    my $this = shift;
    my $class = ref($this) || $this;
    my $self = { };
    bless $self, $class;
    $self->_init(@_);
    return $self;
}

# Parses all passed options to new, such as -from, -name, -smtp, etc.
sub _init {
    my $self = shift;
    my %options = @_;
# These two should be first so that errors can be handled that the others might cause
    $self->show_errors(delete $options{-show_errors}) if exists $options{-show_errors};
    $self->error_code(delete $options{-error_code}) if exists $options{-error_code};
    $self->from(delete $options{-from}) if exists $options{-from};
    $self->name(delete $options{-name}) if exists $options{-name};
    $self->subject(delete $options{-subject}) if exists $options{-subject};
    $self->message(delete $options{-message}) if exists $options{-message};
    $self->success(delete $options{-success}) if exists $options{-success};
    $self->failure(delete $options{-failure}) if exists $options{-failure};
    $self->messagepresend(delete $options{-messagepresend}) if exists $options{-messagepresend};
    $self->subjectpresend(delete $options{-subjectpresend}) if exists $options{-subjectpresend};
    $self->frompresend(delete $options{-frompresend}) if exists $options{-frompresend};
    $self->namepresend(delete $options{-namepresend}) if exists $options{-namepresend};
    $self->smtp_retries(0);
    $self->smtp_retries(delete $options{-smtp_retries}) if exists $options{-smtp_retries};
    $self->smtp_wait(2.5);
    $self->smtp_wait(delete $options{-smtp_wait}) if exists $options{-smtp_wait};
    $self->_method(\%options); # Figures out (sendmail or smtp) and (text or html)
    if (keys %options) {
        my $forgot_dash = 0;
        for (keys %options) {
            $self->_cause_error("Unknown parameter `$_'");
            $forgot_dash++ if substr($_, 0, 1) ne '-';
        }
        die "Invalid parameters (" . join(", ", keys %options) . ") to new()" . ($forgot_dash ? " - perhaps you forgot the -dash?" : "");
    }
}

# Tries to figure out whether to use sendmail, or SMTP to send the message by
# looking for the -smtp or -sendmail options.
# Also looks for -text or -html options
sub _method {
    my ($self,$options) = splice @_,0,2;

    if ($options->{-sendmail} and $options->{-smtp}) {
        $self->_cause_error("Invalid method: Two mailing methods provided. Choose only smtp or sendmail");
        delete $options->{-sendmail};
        delete $options->{-smtp};
    }
    elsif ($options->{-sendmail}) {
        $self->sendmail(delete $options->{-sendmail});
        delete $options->{-smtp};
    }
    elsif ($options->{-smtp}) {
        $self->smtp(delete $options->{-smtp});
        delete $options->{-sendmail};
    }
    my $t = $options->{-text};
    my $h = $options->{-html};
    my $r = $options->{-raw};

    if (($h and $r) or ($t and $r) or ($t and $h)) {
        $self->_cause_error("Invalid mail format: Choose only one format to use.");
        delete $options->{-text};
        delete $options->{-html};
        delete $options->{-raw};
    }
    elsif ($options->{-text}) {
        $self->text(1);
        delete $options->{-text};
        delete $options->{-html};
        delete $options->{-raw};
    }
    elsif ($options->{-html}) {
        $self->html(1);
        delete $options->{-html};
        delete $options->{-text};
        delete $options->{-raw};
    }
    elsif ($options->{-raw}) {
        $self->raw(1);
        delete $options->{-html};
        delete $options->{-text};
        delete $options->{-raw};
    }
}


# This subroutine handles the creation of errors and prints them (if
# show_errors is set), and/or passes them to error_code (if set).
$COMPILE{_cause_error} = __LINE__ . <<'END_OF_SUB';
sub _cause_error {
    my $self = shift;
    my $error = shift;
    warn ref($self)." Error: $error" if $self->{show_errors};
    $self->{error_code}->($error) if ref $self->{error_code} eq 'CODE';
}
END_OF_SUB

# All of the following methods (down to _check_params) will return the current
# value of that parameter if called without arguments.

# Sets a code ref which will be called with an error message each time an
# error occurs.
$COMPILE{error_code} = __LINE__ . <<'END_OF_SUB';
sub error_code {
    my $self = shift;
    if (@_) {
        if (ref $_[0] eq 'CODE') {
            $self->{error_code} = shift;
        }
        else {
            $self->_cause_error("Not a code reference passed to error_code");
        }
    }
    else {
        return $self->{error_code};
    }
}
END_OF_SUB


# Sets whether or not to print errors whenever an error occurs.
$COMPILE{show_errors} = __LINE__ . <<'END_OF_SUB';
sub show_errors {
    my $self = shift;
    if (@_) {
        $self->{show_errors} = shift;
        return;
    }
    return $self->{show_errors};
}
END_OF_SUB

# Sets the e-mail address of the sender. Takes one arg: The e-mail address of
# the sender.
sub from ($;$) {
    my $self = shift;
    if (@_) {
        if (_is_valid_email($_[0])) {
            $self->{from} = shift;
            return 1;
        }
        else {
            $self->_cause_error("Invalid e-mail address: `$_[0]'");
            return;
        }
    }
    else {
        return $self->{from};
    }
}

# Sets the presend code ref for the from field.
# Takes one argument: a code ref
$COMPILE{frompresend} = __LINE__ . <<'END_OF_SUB';
sub frompresend {
    my $self = shift;
    if (@_) {
        $self->{frompresend} = shift if ref $_[0] eq 'CODE';
        return;
    }
    else {
        return $self->{frompresend};
    }
}
END_OF_SUB

# Sets the body of the message.
# Takes one argument: a string.
sub message ($;$) {
    my $self = shift;
    if (@_) {
        $self->{message} = shift;
        return;
    }
    return $self->{message};
}

# Sets a presend code ref for the body of the message.
# Takes a code ref as argument
$COMPILE{messagepresend} = __LINE__ . <<'END_OF_SUB';
sub messagepresend {
    my $self = shift;
    if (@_) {
        $self->{messagepresend} = shift if ref $_[0] eq 'CODE';
        return;
    }
    else {
        return $self->{messagepresend};
    }
}
END_OF_SUB

# Sets the display name of the sender. Will be escaped and quoted.
# Without args, returns the name (not quoted, of course).
sub name ($;$) {
    my $self = shift;
    if (@_) {
        if (_is_valid_name($_[0])) {
            $self->{name} = quote_name(shift);
            return 1;
        }
        else {
            $self->_cause_error("Invalid name");
            return;
        }
    }
    else {
        return unquote_name($self->{name});
    }
}

# name presend - takes a code ref
$COMPILE{namepresend} = __LINE__ . <<'END_OF_SUB';
sub namepresend {
    my $self = shift;
    if (@_) {
        $self->{namepresend} = shift if ref $_[0] eq 'CODE';
        return;
    }
    else {
        return $self->{namepresend};
    }
}
END_OF_SUB

# Sets the subject of the message
sub subject ($;$) {
    my $self = shift;
    if (@_) {
        $self->{subject} = shift;
        return;
    }
    else {
        return $self->{subject};
    }
}

# Sets the subject presend for the e-mail
$COMPILE{subjectpresend} = __LINE__ . <<'END_OF_SUB';
sub subjectpresend {
    my $self = shift;
    if (@_) {
        $self->{subjectpresend} = shift if ref $_[0] eq 'CODE';
        return;
    }
    else {
        return ref $self->{success} eq 'CODE'
                 ? $self->{success}
                 :($self->{success} = undef);
    }
}
END_OF_SUB

# Sets the number of times to attempt connection to the SMTP server before
# giving up.
sub smtp_retries ($;$) {
    my $self = shift;
    if (@_) {
        my $retries = shift;
        if (!$retries or $retries =~ /\D/) {
            $self->{smtp_retries} = 0;
        }
        else {
            $self->{smtp_retries} = $retries;
        }
        return;
    }
    return $self->{smtp_retries};
}

# Sets the wait time between SMTP connection reattempts.
sub smtp_wait ($;$) {
    my $self = shift;
    if (@_) {
        my $wait = shift;
        unless ($wait and $wait =~ /^\d+(?:\.\d+)?$/) {
            $self->{smtp_wait} = 0;
        }
        else {
            $self->{smtp_wait} = $wait;
        }
        return;
    }
    return $self->{smtp_wait};
}

# Sets that the format of the message should be plain text.
# Note that this does NOT set the text of the message!
$COMPILE{text} = __LINE__ . <<'END_OF_SUB';
sub text {
    my $self = shift;
    if (@_) {
        $self->{format} = "text/plain" if $_[0];
        return;
    }
    $self->{format} eq "text/plain";
}
END_OF_SUB

# Sets that the format of the message should be HTML
$COMPILE{html} = __LINE__ . <<'END_OF_SUB';
sub html {
    my $self = shift;
    if (@_) {
        if ($_[0]) {
            $self->{format} = "text/html";
        }
        else {
            $self->{format} = "text/plain";
        }
        return;
    }
    $self->{format} eq "text/html";
}
END_OF_SUB

$COMPILE{raw} = __LINE__ . <<'END_OF_SUB';
sub raw {
    my $self = shift;
    if (@_) {
        $self->{raw} = shift;
        return;
    }
    $self->{raw};
}
END_OF_SUB

# Sets a code reference to be called when a message has (as far as the mailer
# can tell) been sent successfully.
$COMPILE{success} = __LINE__ . <<'END_OF_SUB';
sub success {
    my $self = shift;
    if (@_) {
        $self->{success} = shift if ref $_[0] eq 'CODE';
        return;
    }
    else {
        return ref $self->{success} eq 'CODE'
                 ? $self->{success}
                 :($self->{success} = undef);
    }
}
END_OF_SUB

# Sets a code reference to call when sending a message as failed.
$COMPILE{failure} = __LINE__ . <<'END_OF_SUB';
sub failure {
    my $self = shift;
    if (@_) {
        $self->{failure} = shift if ref $_[0] eq 'CODE';
        return;
    }
    else {
        return ref $self->{failure} eq 'CODE'
               ?   $self->{failure}
               :  ($self->{failure} = undef);
    }
}
END_OF_SUB

# Returns a list of custom headers that have been set
$COMPILE{headers} = __LINE__ . <<'END_OF_SUB';
sub headers {
    my $self = shift;
    wantarray ? %{$self->{header}} : $self->{header};
}
END_OF_SUB

# Adds a single custom header. The header must start with X-
$COMPILE{add_header} = __LINE__ . <<'END_OF_SUB';
sub add_header {
    my $self = shift;
    $self->_cause_error("Wrong number of arguments to add_header()") and return unless @_ == 2;
    my ($k,$v) = splice @_,0,2;
    $k =~ y/\x00-\x1f://d;
    $v =~ s/\r?\n/$CRLF/g;
    $v =~ s/(?:$CRLF){2,}/$CRLF/g;
    $v =~ s/$CRLF$//;
    if (($self->raw) || (substr($k,0,2) eq 'X-')) {
        $self->{header}{$k} = $v;
    }
    else {
        $self->_cause_error("Only X-* headers can be added");
    }
}
END_OF_SUB

# Adds multiple headers. This makes calls to add_header()
$COMPILE{add_headers} = __LINE__ . <<'END_OF_SUB';
sub add_headers {
    my $self = shift;
    $self->_cause_error("Wrong number of arguments to add_headers()") and return if @_ % 2;
    while (@_) {
        $self->add_header(splice @_,0,2);
    }
}
END_OF_SUB

# Deletes (and returns the value of) the header given.
$COMPILE{delete_header} = __LINE__ . <<'END_OF_SUB';
sub delete_header {
    my $self = shift;
    my $key = shift;
    delete $self->{header}{$key};
}
END_OF_SUB

# Deletes (and returns the values of) the headers given.
$COMPILE{delete_headers} = __LINE__ . <<'END_OF_SUB';
sub delete_headers {
    my $self = shift;
    delete @{$self->{header}}{@_};
}
END_OF_SUB

# Sets the sending method to SMTP and sets the smtp server to the argument
# given.
$COMPILE{smtp} = __LINE__ . <<'END_OF_SUB';
sub smtp {
    my $self = shift;
    if (@_) {
        my $smtp = shift;
        chomp $smtp;
        if ($smtp =~ /^$VALID_HOST\Z/) {
            $self->{method}   = "smtp";
            delete $self->{sendmail};
            $self->{smtp}     = $smtp;
            $self->{smtp_attempts} = 0;
            $self->{smtp_connected} = 0;
            delete $self->{handle_in};
            delete $self->{handle_out};
            delete $self->{smtp_supported};
            return 1;
        }
        else {
            $self->_cause_error("Bad SMTP server name provided ($smtp)");
            return;
        }
    }
    else {
        return $self->{smtp};
    }
}
END_OF_SUB

# Sets the sending method to sendmail and sets the sendmail path to the
# argument given.
$COMPILE{sendmail} = __LINE__ . <<'END_OF_SUB';
sub sendmail {
    my $self = shift;
    if (@_) {
        my $sendmail = shift;
        my ($executable, $tags) = split ' ', $sendmail, 2;
        if (-x $executable) {
            $self->{method}   = "sendmail";
            if ($tags) {
                $self->{sendmail_with_tags} = $self->{sendmail} = $sendmail;
                # Using tags assumes that a method equivelant to -t is being used
                $self->{no_sendmail_bs} = 1;
            }
            else {
                $self->{sendmail} = $sendmail;
                delete $self->{no_sendmail_bs};
            }
            return 1;
        }
        else {
            $self->_cause_error("Cannot execute $sendmail");
            return 0;
        }
    }
    else {
        return $self->{sendmail_with_tags} || $self->{sendmail};
    }
}
END_OF_SUB

# checks that there is enough information set to send the e-mail
sub _check_params {
    my $self = shift;
    my $errors = "";
    unless ($self->{from}) {
        $errors .= "`from' address not set. ";
    }
    elsif (not _is_valid_email($self->{from})) {
        $errors .= "`$self->{from}' is not a valid e-mail address. ";
    }
    if ($self->{name} and not _is_valid_name($self->{name})) {
        $errors .= "`$self->{name}' is not a valid name. ";
    }
    unless ($self->{$self->{method}}) {
        $errors .= "No mail sending method set! ";
    }
    $errors and $self->_cause_error($errors . "Send aborted."), return;
    return 1;
}

# Checks whether or not the provided e-mail address is valid.
$COMPILE{_is_valid_email} = __LINE__ . <<'END_OF_SUB';
sub _is_valid_email {
    shift if ref $_[0];
    my $email = shift;
    return $email && $email =~ /^[\x21-\x7e]+\@$VALID_HOST$/;
}
END_OF_SUB

# Checks that a name is valid.
$COMPILE{_is_valid_name} = __LINE__ . <<'END_OF_SUB';
sub _is_valid_name {
    shift if ref $_[0];
    my $name = shift;
    return not $name =~ y/\x20-\x7e//c; # 7-bit only with no control characters
}
END_OF_SUB

# Sends an e-mail. Takes multiple arguments: Any number of:
# - array references
# - code references
# - hash references
# - glob references
# See the perldoc of this file for more info
sub send {
    my $self = shift;
    unless ($self->_check_params) {
        $self->_cause_error("Not all neccessary parameters provided. No emails sent.");
        return;
    }
    else {
        $self->{date} = RFC822_date(); # Just get it once rather than figuring it out each time.
        if ($self->{method} eq 'smtp') {
            $self->_smtp_connect();
        }
        elsif ($self->{method} eq 'sendmail') {
            $self->_sendmail_connect();
        }
        for (@_) {
            ref eq 'GLOB'  and $self->_send_globref($_),  next;
            ref eq 'HASH'  and $self->_send_hashref($_),  next;
            ref eq 'ARRAY' and $self->_send_arrayref($_), next;
            ref eq 'CODE'  and $self->_send_coderef($_),  next;
            $self->_cause_error("Invalid argument to ".ref($self)."->send()");
        }
    }
}

$COMPILE{_send_arrayref} = __LINE__ . <<'END_OF_SUB';
sub _send_arrayref {
    my $self = shift;
    my $array = shift;
    for (@$array) {
        $self->_send_one($_);
    }
}
END_OF_SUB

$COMPILE{_send_coderef} = __LINE__ . <<'END_OF_SUB';
sub _send_coderef {
    my $self = shift;
    my $code = shift;
    my ($id,$email);
    $id = "temp";
    while ($id) {
        ($id, $email) = $code->() or last;
        $self->_send_one($email ? ($id,$email) : $id);
    }
}
END_OF_SUB

$COMPILE{_send_globref} = __LINE__ . <<'END_OF_SUB';
sub _send_globref {
    my $self = shift;
    my $file = shift;
    unless (defined fileno $file) {
        $self->_cause_error("Glob reference passed to send is not an opened file");
        return;
    }
    my $addr;
    while ($addr = <$file>) {
        $addr =~ s/\r?\n$//; # Allow for windows line ends on *nix systems
        $self->_send_one($addr);
    }
}
END_OF_SUB

$COMPILE{_send_hashref} = __LINE__ . <<'END_OF_SUB';
sub _send_hashref {
    my $self = shift;
    my $hash = shift;
    my ($id,$email);
    $self->_send_one($id,$email) while ($id,$email) = each %$hash;
}
END_OF_SUB

# Sends a single e-mail message. Should not be called except by one of the 4
# subroutines above.
sub _send_one {
    my $self = shift;
    my ($id,$email) = @_ > 1 ? (splice @_,0,2) : ((shift) x 2);
    substr($email,rindex($email,'@')) =~ y/A-Z/a-z/;
    my $success;
    my $from = ref $self->{frompresend} eq 'CODE'
                 ? ($self->{frompresend}->($id,$self->{from}) || $self->{from})
                 : $self->{from};
    $from =~ y/\x21-\x7e//cd;
    my $name = ref $self->{namepresend} eq 'CODE'
                 ? quote_name($self->{namepresend}->($id,unquote_name($self->{name}))) || $self->{name}
                 : $self->{name};
    $name =~ y/\x20-\x7e//cd;
    my $subject;
    $subject = ref $self->{subjectpresend} eq 'CODE'
                    ? ($self->{subjectpresend}->($id,$self->{subject}) || $self->{subject})
                    : $self->{subject};
    $subject =~ y/\x20-\x7e//cd;
    my $message = ref $self->{messagepresend} eq 'CODE'
                    ? ($self->{messagepresend}->($id,$self->{message}) || $self->{message})
                    : $self->{message};
    if ($self->{method}) {
        if ($noIPCOpen2 || $self->{no_sendmail_bs} and $self->{method} eq 'sendmail') {
            $success = $self->_sendmail_t_send($email,$from,$name,$subject,$message);
        }
        else {
            $success = $self->_smtp_send($email,$from,$name,$subject,$message);
        }
    }
    else {
        $self->_cause_error("No mail sending method set!");
        return;
    }
    if ($success and ref $self->{success} eq 'CODE') {
        $self->{success}->($id);
    }
    elsif (!$success and ref $self->{failure} eq 'CODE') {
        $self->{failure}->($id);
    }
}

# Creates a connection to the STMP server
$COMPILE{_smtp_connect} = __LINE__ . <<'END_OF_SUB';
sub _smtp_connect {
    my $self = shift;
    $self->_smtp_disconnect if $self->{smtp_connected};
    $self->{method} eq 'sendmail' and return $self->_sendmail_connect;
    local $/ = CRLF;
    local $\ = CRLF;

    my $s;
    $self->{smtp_connected} = 0;

    while (not $self->{smtp_connected} and $self->{smtp_attempts}++ <= $self->{smtp_retries}) {
        select(undef,undef,undef,$self->{smtp_wait}) if $self->{smtp_attempts} > 1
            and $self->{smtp_wait} and $self->{smtp_wait} > 0;

        $s = GT::Socket::Client->open(
            host => $self->{smtp},
            port => 25,
            timeout => 10
        ) or $self->_cause_error("$self->{smtp}: Unable to connect: " . GT::Socket::Client->error);

        $self->{handle_out} = $self->{handle_in} = $s;
        $_ = <$s>;
        unless (/^220/) {
            $self->_cause_error("$self->{smtp}: Server not available: $_");
            close $s;
            next;
        }
        while (/^220-/) {
            $_ = <$s>;
        }
        if (my $error = $self->_smtp_say_hi) {
            $self->_cause_error("$self->{smtp}: $error");
            close $s;
            next;
        }
        $self->{smtp_connected} = 1;
    }
    return $self->{smtp_connected};
}
END_OF_SUB

# Disconnects from the SMTP server
sub _smtp_disconnect {
    my $self = shift;
    return $self->_sendmail_disconnect if $self->{method} eq 'sendmail';
    local $/ = CRLF;
    local $\ = CRLF;
    my $in = $self->{handle_in};
    my $out = $self->{handle_out};
    if (defined $out) {
        print $out "QUIT";
    }
    close $out;
    close $in;
    delete $self->{handle_out};
    delete $self->{handle_in};
    1;
}

# Does all the initialization required before sending a message
$COMPILE{_smtp_say_hi} = __LINE__ . <<'END_OF_SUB';
sub _smtp_say_hi {
    my $self = shift;
    my $in = $self->{handle_in};
    my $out = $self->{handle_out};
    local $/ = CRLF;
    local $\ = CRLF;
    print $out "EHLO localhost";
    local $_ = <$in>;
    return "No server response" unless defined;
    if (/^5\d\d\s+(.*)/) { # Not ESMTP
        delete $self->{smtp_esmtp};
        print $out "HELO localhost";
        $_ = <$in>;
        return "No server response to HELO command (EHLO failed)" unless defined;
    }
    else {
        $self->{smtp_esmtp}++;
    }
    s/$CRLF/\n/;
    return "Invalid server response: $_" if !/^\d{3}/;
    return "Server error: $_" if /^[45]/;
    return if /^250 /; # Just a plain SMTP greeting
    while (defined($_=<$in>) and /^250-/) { # 250- is a possible greeting, indicating more lines coming.
        s/$CRLF/\n/;
        /^(?:221|[45]\d\d)\s*(.*)/ and return "Server disconnected: $1";
    }
    !defined || /^(?:221|[45]\d\d)\s*(.*)/ and return "Server disconnected: $1";
    return;
}
END_OF_SUB

# Actually sends the message using SMTP protocols.
$COMPILE{_smtp_send} = __LINE__ . <<'END_OF_SUB';
sub _smtp_send {
    my ($self,$to,$from,$name,$subject,$message) = @_;
    return unless _is_valid_email($to);
    local $/ = CRLF;
    local $\ = CRLF;
    local $_;

    unless ($self->{smtp_connected}) {
        $self->_smtp_connect();
    }
    my $in = $self->{handle_in};
    my $out = $self->{handle_out};
    print $out "RSET";
    $_ = <$in>;
    s/$CRLF$//;
    if (not defined or /^(?:221|[45]\d\d)\s*(.*)/) {
        $self->_cause_error("Cannot reset connection: ".($1 || "No response from server").". Reconnecting");
        $self->{smtp_attempts} = 0; # It could be that the server will only take one connection, although
        # this defeats any advantage this module has over any module designed to send just one message.
        unless ($self->_smtp_connect()) {
            $self->_cause_error("Fatal: Could not reestablish connection");
            die "Could not reestablish connection";
        }
    }
    if (/^221\s*(.*)/) {
        $self->_smtp_disconnect();
        $self->_cause_error("Server disconnected: $1");
        return;
    }

    my $return = $self->{header}->{'Return-Path'} || $from;
    print $out "MAIL FROM: <$return>";

    $_ = <$in>;
    s/$CRLF$//;
    if (/^221\s*(.*)/) {
        $self->_smtp_disconnect();
        $self->_cause_error("Server disconnected: $1");
        return;
    }
    unless (/^250/) {
        # The error message won't be helpful here (it will be a syntax error).
        # The only way an error can occur here is for an invalid email address.
        $self->_cause_error("From address (`$from') rejected by server ($_)");
        # If the from was rejected once, it will be rejected again.
        die "From address (`$from') rejected by server.";
    }
    print $out "RCPT TO: <$to>";
    $_ = <$in>;
    s/$CRLF$//;
    if (/^221\s*(.*)/) {
        $self->_smtp_disconnect;
        $self->_cause_error("Server disconnected: $1. Attempting to reconnect...");
        $self->{smtp_attempts} = 0;
        unless ($self->_smtp_connect()) {
            $self->_cause_error("Fatal error: Could not reestablish connection");
            die "Could not reestablish connection";
        }
        return &_smtp_send; # redo this mail
    }
    unless (/^25[01]/) {
        /^\d{3}\s*(.*)/;
        $self->_cause_error("Recipient ($to) refused by server: $1");
        return;
    }
    print $out "DATA";
    $_ = <$in>;
    s/$CRLF$//;
    if (/^221\s*(.*)/) {
        $self->_smtp_disconnect;
        $self->_cause_error("Server disconnected: $1. Attempting to reconnect...");
        $self->{smtp_attempts} = 0;
        unless ($self->_smtp_connect) {
            $self->_cause_error("Fatal error: Could not reestablish connection");
            die "Could not reestablish connection";
        }
        return &_smtp_send; # redo this mail
    }
    unless (/^354/) {
        $self->_cause_error("Invalid server response to DATA ($_). Attempting to reset and resend.");
        return &_smtp_send;
    }
    my $perl_version = $^V ? (join ".",map ord, split //,$^V) : $];
    $from = "$name <$from>" if defined $name and $name =~ /\S/;
    print $out "Return-Path: $return";
    print $out "Date: $self->{date}";
    print $out "From: $from";
    print $out "Subject: $subject";
    print $out "To: $to";
    print $out "MIME-Version: 1.0" unless exists $self->{header}->{'MIME-Version'};
    print $out "Content-Transfer-Encoding: quoted-printable" unless exists $self->{header}->{'Content-Transfer-Encoding'};
    print $out "Content-Type: $self->{format}" if $self->{format};
    my $host = $self->{smtp} && $self->{smtp} ne 'localhost' && $self->{smtp} !~ /^\s*127\.\d+\.\d+\.\d+\s*$/ ? $self->{smtp} : $ENV{SERVER_NAME} && $ENV{SERVER_NAME} ne 'localhost' ? $ENV{SERVER_NAME} : '';
    if ($host) {
        print $out 'Message-Id: <' . time . '.' . $$ . rand(10000) . '@' . $host . '>';
    }
    while (my ($k,$v) = each(%{$self->{header}})) {
        next if $k eq 'Return-Path' or $k eq 'X-Mailer' or $k eq 'Message-Id';
        print $out "$k: $v";
    }
    print $out "";
    $message =~ s/\015?\012/$CRLF/g if $self->{raw};
    $message = quoted_printable($message) unless $self->{raw};
    $message =~ s/^\./../gm;
    print $out $message;
    print $out ".";
    $_ = <$in>;
    return /^250/;
}
END_OF_SUB

# Establishes a sendmail -bs (emulates SMTP) connection via IPC::Open2
$COMPILE{_sendmail_connect} = __LINE__ . <<'END_OF_SUB';
sub _sendmail_connect {
    my $self = shift;
    local $/ = CRLF;
    local $\ = CRLF;
    my $in  = \do { local *INPUT; *INPUT; };
    my $out = \do { local *OUTPUT; *OUTPUT; };
    $self->_smtp_disconnect if $self->{sendmail_pid} or $self->{smtp_connected};
    my $pid = eval { open2($in,$out,"$self->{sendmail} -bs") };

    $self->{handle_in} = $in;
    $self->{handle_out} = $out;
    if ($@) {
        # Could not run sendmail at all
        $self->_cause_error("Unable to open sendmail: $@");
        return;
    }
    $_ = <$in>;
    s/\n$//;
    unless (/^220/) {
        # sendmail can be run, but apparently it doesn't like the -bs option
        $self->_cause_error("$self->{sendmail}: SMTP compatible mode not available: $_. Using -t mode instead.");
        close $in;
        close $out;
        waitpid $pid,0;
        $self->{no_sendmail_bs}++;
        return 1;
    }
    while (/^220-/) {
        $_ = <$in>;
    }
    if (my $error = $self->_smtp_say_hi) {
        $self->_cause_error("Sendmail (SMTP mode) error: $error");
        close $in;
        close $out;
        waitpid $pid,0;
        return;
    }
    $self->{sendmail_pid} = $pid;
    $self->{smtp_connected} = 1;
    return 1;
}
END_OF_SUB

# Disconnects from sendmail (in sendmail -bs mode)
$COMPILE{_sendmail_disconnect} = __LINE__ . <<'END_OF_SUB';
sub _sendmail_disconnect {
    my $self = shift;
    my $in = $self->{handle_in};
    my $out = $self->{handle_out};
    my $pid = $self->{sendmail_pid};
    close $in if $in;
    close $out if $out;
    waitpid $pid, 0 if $pid;
    delete $self->{handle_in};
    delete $self->{handle_out};
    delete $self->{sendmail_pid};
    delete $self->{smtp_connected};
    1;
}
END_OF_SUB

# Sends with sendmail -t mode. This should only be called when IPC::Open2 is
# not available or sendmail does not support the -bs switch. It is intended as
# a backup solution only.
$COMPILE{_sendmail_t_send} = __LINE__ . <<'END_OF_SUB';
sub _sendmail_t_send {
    my ($self,$to,$from,$name,$subject,$message) = splice @_,0,6;
    local $/ = LF;
    local $\ = LF;
    return unless _is_valid_email($to);
    local *SENDMAIL;
    my $to_open = $self->{sendmail_with_tags} || "$self->{sendmail} -t -oi -odq";
    unless (open(SENDMAIL, "| $to_open"))
    {
        $self->_cause_error("Can't run sendmail ($to_open): $!");
        return;
    }
    my $return = $self->{header}->{'Return-Path'} || $from;
    $from = "$name <$from>" if defined $name and $name =~ /\S/;
    my $perl_version = $^V ? (join ".",map ord, split //,$^V) : $];
    print SENDMAIL "Return-Path: $return";
    print SENDMAIL "Date: $self->{date}";
    print SENDMAIL "From: $from";
    print SENDMAIL "Subject: $subject";
    print SENDMAIL "To: $to";
    print SENDMAIL "MIME-Version: 1.0" unless exists $self->{header}->{'MIME-Version'};
    print SENDMAIL "Content-Transfer-Encoding: quoted-printable" unless exists $self->{header}->{'Content-Transfer-Encoding'};
    print SENDMAIL "Content-Type: $self->{format}" if $self->{format};
    my $host = $ENV{SERVER_NAME} && $ENV{SERVER_NAME} ne 'localhost' ? $ENV{SERVER_NAME} : '';
    if ($host) {
        print SENDMAIL 'Message-Id: <' . time . '.' . $$ . rand(10000) . '@' . $host . '>';
    }
    while (my ($k,$v) = each %{$self->{header}}) {
        next if $k eq 'Return-Path' or $k eq 'X-Mailer' or $k eq 'Message-Id';
        print SENDMAIL "$k: $v";
    }
    unless ($self->{raw}) {
        $message = quoted_printable($message);
# quoted_printable returns a string with CRLF newlines
        $message =~ s/$CRLF/$LF/gs;
    }
    $message =~ s/^\.$LF$/. $LF/gm;
    print SENDMAIL $message;
    close SENDMAIL;
    !$?;
}
END_OF_SUB

# Returns the argument passed with quotes around it and special characters
# escaped for use in the From: line of an e-mail.
sub quote_name {
    shift if ref $_[0]; # In case you call $self->quote_name($string);
    my $toquote = shift;
    $toquote =~ s/(?=[(")\\])/\\/g;
    substr($toquote,0,0) = '"';
    $toquote .= '"';
    $toquote;
}

# unquotes (as per the above) the argument
$COMPILE{unquote_name} = __LINE__ . <<'END_OF_SUB';
sub unquote_name {
    shift if ref $_[0];
    my $tounquote = shift;
    $tounquote =~ s/^"// and $tounquote =~ s/"$//;
    $tounquote =~ s/\\(?=.)//g;
    return $tounquote;
}
END_OF_SUB

# Takes a string and returns it in quoted-printable encoding.
sub quoted_printable {
    shift if ref $_[0];
    my $in = shift || "";
    my $out;
    GT::Mail::Encoder->gt_encode(encoding => 'quoted-printable', in => $in, out => sub { $out .= $_[0] });
    $out;
}

# Returns an RFC822 compliant date.
sub RFC822_date (;$$) {
    require GT::Date;
    GT::Date->import(':timelocal');
    shift if ref $_[0];
    my $time = @_ ? shift : time;
    my @lt = localtime($time);
    my @ut = gmtime($time);
    use integer;
    my $tzs = (timegm(@lt) - timelocal(@lt));
    my $tzh = $tzs / 3600;
    my $tzm = $tzs % 60 / 60;
    my $tz = 100*$tzh + 60*$tzm;
    no integer;
    sprintf(
        "%s, %02d %s %04d %02d:%02d:%02d %+05d",
        (qw/Sun Mon Tue Wed Thu Fri Sat/)[$lt[6]],
        $lt[3],
        (qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/)[$lt[4]],
        $lt[5] + 1900,
        @lt[2,1,0],
        $tz
    );
}

1;

__END__

=head1 NAME

GT::Mail::BulkMail - A (perhaps overly) simplified interface to sending bulk emails

=head1 SYNOPSIS

    $mailer = new GT::Mail::BulkMail;
    $mailer->option("setting");
    $mailer->otheroption("othersetting");
    ...
    
    -- or --

    $mailer = new GT::Mail::BulkMail(
        -option      => "setting",
        -otheroption => "othersetting",
        ...
    );



    -- then --


    sub subroutine {
        # Code to generate the next e-mail address
    }
    open FILE, "email_list.txt";
    %hash = ( 1 => 'some@fictional.address',
              2 => 'who@knows.where'
            );
    @array = ('yet@another.fictional.address','and@one.more');
    $mailer->send(\&subroutine,\*FILE,\%hash,\@array);
    close FILE;


=head1 DESCRIPTION

GT::Mail::BulkMail is a module to handle mass mailings. It is capable of
using either sendmail, or an SMTP server. It has the advantage of
not requiring multiple connections to the SMTP server.

=head1 REQUIREMENTS

Perl 5.004

=head2 METHODS

All methods can be specified at object creation time as an option with the:
S<-option =E<gt> value> syntax. For example, C<$mailer = new GT::Mail::BulkMail(-from =E<gt> "foo@bar.com")>
would have the same effect as: C<$mailer = new GT::Mail::BulkMail(); $mailer-E<gt>from("foo@bar.com")>

=over 4

=item smtp

Sets the SMTP server to use, and sets the object mail sending method to use SMTP. Takes
SMTP server as argument.

=item sendmail

Sets the sendmail executable to use. Takes the path to sendmail as the argument.

=item text

Specifies that the mail format is text. This translates into Content-type: text/plain.
This is the default format.

=item html

Specifies that the mail format is HTML. (Content-type: text/html)

=item headers

Returns any custom headers set as a hash reference in scalar context, or a hash in list context.

=item add_header

Adds a single header. This can be any header starting with "X-" (Note that X-Mailer headers
will be prepended with the GT::Mail::BulkMail X-Mailer header (which includes the perl version,
OS name, GT::Mail::BulkMail module and CVS versions, and the Gossamer Threads homepage)). Pass
two arguments: A key (header name) and a value (header value). For example, for
C<X-Foo: blah blah blah> you would use: $mailer->add_header("X-Foo" => "blah blah blah")

=item add_headers

Same as above, except it adds multiple headers. Has the same argument format. You would use:
$mailer->add_headers("X-Foo1" => "blah", "X-Foo2" => "blah blah");

=item delete_header

Deletes a single header. Pass the name of the header to delete.

=item delete_headers

Delete multiple headers. Pass a list of names of headers to delete.

=item from

Sets the "from" field of the e-mail. Must be set before $mailer-E<gt>send() can be called.
Must be set to an  e-mail address. If this e-mail address is rejected by the SMTP server,
no e-mails will be sent.

=item name

Sets the "name" field of the e-mail. This affects what is displayed in the "From" field.
When sending the email, the actual field will be set to: C<"This name" E<lt>some@name.netE<gt>>.
Optional.

=item subject

Sets the subject of the message. If not specified, it will default to "(no subject)"

=item message

The body of the message. Can be left blank, but that seems rather pointless...
The message will be encoded using the quoted-printable format if it contains characters
outside the 7-bit range.

=item success

A code reference to be run for each and every successful e-mail sending.
Each call to this code reference will be given the e-mail address as the only argument
(unless using a message ID, which is discussed below). Optional.

=item failure

A code reference that will be run for any email addresses that cannot be sent. Each
call to this code reference will be given the ID or e-mail address as the argument
(message IDs are discussed below). Optional.

=item frompresend

=item namepresend

=item subjectpresend

=item messagepresend

A code reference that will be run before sending an e-mail. The 'from', 'name', 'subject',
or 'message' field will be sent to the code references (depending on which method called)
and whatever is returned will be used as the actual field for the email sent. This can be
used to parse fields to customize them for each recipient. The subroutine is called with
two arguments: (ID_OR_EMAIL, FIELD). If an ID is provided, it will be passed as the
first argument, otherwise the email address will be passed. The second argument is the
field itself. The field used in the actual email to the user will be the value returned by
the subroutine.

The default field (for the rest of the mailing) can be changed by directly modifying $_[1]
itself.

If the subroutine reference returns an undefined value, the mailer will use the actual field 
instead. You can use this technique to only modify some messages, but not others.

Optional.

=item show_errors

If set to something true it will warn() on all errors. Optional. The default is turned on,
but can easily be changed by modifying the line '

=item error_code

Takes a code reference - the code reference will be called with the error as the argument
when an error occurs. Optional.

=item send

Takes any number of the following arguments:

=over 8

=item array reference

An array reference of a list of e-mail addresses to send to. After each message, either the
success or failure callback will be called with the e-mail address as the argument, and
possibly a message as the second argument.

=item hash reference

A hash reference of ID =E<gt> email pairs. For example,
123 =E<gt> 'someone@whoknows.com'. The value will be used as the e-mail address to send
to, and the key will be an identifier to pass into the success or failure callbacks.

=item glob reference

A glob reference to an open file. Make sure the file is opened before passing this!
The file should contain one e-mail address per line.

=item subroutine or code reference

You may pass a code reference, and it will be called for each e-mail address. It is
assumed that the subroutine will return one e-mail address each time called, and
that a return value of "undef" indicates that there are no more e-mail addresses.
The code reference could alternatively return two items - if it does, it is assumed that
the first is an ID code, and that the second is the email address. When a call to either
or the success or failure callbacks, the ID will be provided as the first argument
instead of the e-mail address itself.

One cool feature to note about using code refs is that you can call next() from within
the code reference and it will then recall the code reference for the next value.

=cut
