# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
#   GT::Mail
#   Author  : Scott Beck
#   CVS Info :                          
#   $Id: Mail.pm,v 1.70 2004/11/04 20:23:09 brewt Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc.  All Rights Reserved.
# ==================================================================
#
# Description: A general purpose perl interface to sending, creating, and
# parsing emails.
#

package GT::Mail;
# ==================================================================
# Pragmas
use strict;
use vars qw/$DEBUG @ISA $ERRORS $CRLF @HEADER $VERSION %CONTENT $CONTENT/;

# Internal modules
use GT::Base;
use GT::MIMETypes;
use GT::Mail::Encoder;
use GT::Mail::Parts;
use GT::Mail::Send;

# Damn warnings
$GT::Mail::error = '' if 0;

$VERSION = sprintf "%d.%03d", q$Revision: 1.70 $ =~ /(\d+)\.(\d+)/;
@ISA     = qw(GT::Base);
$DEBUG   = 0;
$CRLF    = "\012";
$|       = 1;

$ERRORS = {
    PARSE   => "Unable to parse message: %s",
    SEND    => "Unable to send email: %s",
    NOIO    => "No input to parse!",
    NOBOUND => "Multipart message has not boundary",
    NOEMAIL => "No message head was specified",
    NOBODY  => "No body was found in message",
};

# To guess the content-type for files by extension
%CONTENT = GT::MIMETypes->content_ext;
$CONTENT = \%CONTENT;  # Other programs still access this as a hash reference.

sub new {
# -----------------------------------------------------------------------------
# CLASS->new(
#     debug   => 1,
#     to      => 'user1@domain',
#     from    => 'user2@domain',
#     subject => 'Hi Alex',
#     type    => 'multipart/mixed',
#     ...
# );
# -----------------------------------------------------------------------------
# Returm a new mail object. If you pass in the header information the new
# mail's header will be initialized with those fields.
    my $this = shift;
    my $self;

# Calling this as an object method does not create a new object.
    if (ref $this) { $self = $this }
    else { $self = bless {}, $this }

    $self->args(@_) if @_;
    exists($self->{_debug}) or $self->{_debug} = $DEBUG;

    $self->debug("Created new object ($self).") if ($self->{_debug} > 1);
    return $self;
}

sub args {
    my $self = shift;
    my $opt  = {};
    if (defined $_[0] and not @_ % 2) { $opt = {@_} }
    elsif (ref $_[0] eq 'HASH') { $opt = shift }

    $self->{_debug}         = exists($opt->{debug}) ? delete $opt->{debug} : $DEBUG;
    $self->{smtp}           = delete $opt->{smtp}           || '';
    $self->{smtp_port}      = delete $opt->{smtp_port}      || '';
    $self->{smtp_ssl}       = delete $opt->{smtp_ssl}       || '';
    $self->{smtp_user}      = delete $opt->{smtp_user}      || '';
    $self->{smtp_pass}      = delete $opt->{smtp_pass}      || '';
    $self->{pbs_user}       = delete $opt->{pbs_user}       || '';
    $self->{pbs_pass}       = delete $opt->{pbs_pass}       || '';
    $self->{pbs_host}       = delete $opt->{pbs_host}       || '';
    $self->{pbs_port}       = delete $opt->{pbs_port}       || '';
    $self->{pbs_auth_mode}  = delete $opt->{pbs_auth_mode}  || 'PASS';
    $self->{pbs_ssl}        = delete $opt->{pbs_ssl}        || '';
    $self->{flags}          = delete $opt->{flags}          || '';
    $self->{sendmail}       = delete $opt->{sendmail}       || '';
    $self->{header_charset} = delete $opt->{header_charset} || 'ISO-8859-1';

    if (keys %{$opt} and !$self->{head}) {
        $self->{head} = $self->new_part($opt);
    }
    elsif (keys %{$opt} and $self->{head}) {
        $self->header($self->{head}, $opt);
    }

    return $self;
}

sub parse {
# --------------------------------------------------------------------------
# $obj->parse(\*FH);
# ------------------
# $obj->parse('/path/to/file');
# -----------------------------
# $obj->parse($SCALAR_REF -or- $SCALAR);
# --------------------------------------
# Takes either a path to a file for a file handle.  Returns 1 on success and
# undef on failure. If a filehandle is specified this will attempt to seek back
# to 0, 0 on exit.
#
    my ($self, $io) = @_;

# Require our parser
    require GT::Mail::Parse;

# Get a new parser object
    $self->{parser} ||= new GT::Mail::Parse (debug => $self->{_debug});
    $self->_set_io($io) or return;
    $self->debug("\n\t--------------> Parsing email.") if $self->{_debug};
    $self->{head} = $self->{parser}->parse or return $self->error("PARSE", "WARN", $GT::Mail::Parse::error);
    $self->debug("\n\t<-------------- Email parsed.") if $self->{_debug};
    return $self->{head};
}

sub parse_head {
# -----------------------------------------------------------------------------
# $obj->parse_head (\*FH);
# ------------------------
# $obj->parse_head ('/path/to/file');
# -----------------------------------
# This method does the exact same thing as the parse method except it will only
# parse the header of the file or filehandle. This is a nice way to save
# overhead when all you need is the header parsed and do not care about the
# rest of the email.
# NOTE: The top level part is returned from this and not stored.
#
    my ($self, $io) = @_;

# Require our parser
    require GT::Mail::Parse;

# Get a new parser object
    $self->{parser} ||= new GT::Mail::Parse (debug => $self->{_debug});
    $self->_set_io($io) or return;
    $self->debug("\n\t--------------> Parsing head") if $self->{_debug};
    my $part = $self->{parser}->parse_head or $self->error("PARSE", "WARN", $GT::Mail::Parse::error);
    $self->debug("\n\t<-------------- Head parsed") if $self->{_debug};
    return $part;
}

sub parser {
# -----------------------------------------------------------------------------
# my $parser = $mail->parser;
# ---------------------------
# $mail->parser($parser);
# -----------------------
# Set or get method for the parser object that is used when you call
# parse_head() or parse(). This object must conform to the method parse and
# parse_head. If no object is passed to this method a GT::Mail::Parse object is
# created when needed.
#
    my ($self, $parser) = @_;
    if (defined $parser) {
        $self->{parser} = $parser;
        $self->{head}   = $parser->top_part;
    }
    return $self->{parser};
}

sub send {
# -----------------------------------------------------------------------------
# CLASS->send(smtp => 'host.com', smtp_ssl => 1, smtp_port => 4650, To => '...', ...);
# ------------------------------------------------------------------------------------
# $obj->send(smtp => 'host.com', smtp_ssl => 1, smtp_port => 4560);
# -----------------------------------------------------------------
# $obj->send(sendmail => '/path/to/sendmail', flags => $additional_flags);
# ------------------------------------------------------------------------
# Sends the current email through either smtp or sendmail.  The sendmail send
# takes additional arguments as flags that get passed to sendmail (e.g.
# "-t -oi -oem").  If these flags are specified they override the default which
# is "-t -oi -oem".  The smtp send also looks for smtp_port and smtp_ssl, but
# these are optional and default to port 110, non-encrypted.  Note that using
# an SSL encrypted connection requires Net::SSLeay.  Also not that attempting
# to establish an SSL connection when Net::SSLeay (at least version 1.06) is
# not available will cause a fatal error to occur.
#
    my $self = shift;
    unless (ref $self) {
        $self = $self->new(@_);
    }
    elsif (@_) {
        $self->args(@_);
    }
    $self->{head} or return $self->error("NOEMAIL", "FATAL");

# Set a Message-Id if we don't have one set already
    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 (not defined $self->{head}->get('Message-Id') and $host) {
        $self->{head}->set('Message-Id' => '<' . time . '.' . $$ . rand(10000) . '@' . $host . '>');
    }

    if ($self->{sendmail} and -e $self->{sendmail} and -x _) {
        $self->debug("\n\t--------------> Sending email through Sendmail path: ($self->{sendmail})") if $self->{_debug};
        my @flags = exists($self->{flags}) ? (flags => $self->{flags}) : ();
        my $return = ($self->parse_address($self->{head}->get('Reply-To') || $self->{head}->get('From')))[1];
        $self->{head}->set('Return-Path' => "<$return>") unless $self->{head}->get('Return-Path');
        GT::Mail::Send->sendmail(
            debug => $self->{_debug},
            path  => $self->{sendmail},
            mail  => $self,
            @flags
        ) or return $self->error("SEND", "WARN", $GT::Mail::Send::error);
        $self->debug("\n\t<-------------- Email sent through Sendmail") if $self->{_debug};
    }
    elsif ($self->{smtp} and $self->{smtp} =~ /\S/) {
# SMTP requires \r\n
        local $CRLF = "\015\012";
        local $GT::Mail::Parts::CRLF = "\015\012";
        local $GT::Mail::Encoder::CRLF = "\015\012";
        $self->{head}->set(date => $self->date_stamp) unless ($self->{head}->get('date'));
        $self->debug("\n\t--------------> Sending email through SMTP host: ($self->{smtp}:$self->{smtp_port})") if $self->{_debug};
        GT::Mail::Send->smtp(
            debug         => $self->{_debug},
            host          => $self->{smtp},
            port          => $self->{smtp_port}, # Optional; GT::Mail::Send will set a default if not present
            ssl           => $self->{smtp_ssl},  # Make sure Net::SSLeay is available if you use this
            user          => $self->{smtp_user}, # Optional; Used for SMTP AUTH (CRAM-MD5, PLAIN, LOGIN)
            pass          => $self->{smtp_pass},
            pbs_host      => $self->{pbs_host},  # Optional; Perform a POP3 login before sending mail
            pbs_port      => $self->{pbs_port},
            pbs_user      => $self->{pbs_user},
            pbs_pass      => $self->{pbs_pass},
            pbs_auth_mode => $self->{pbs_auth_mode},
            pbs_ssl       => $self->{pbs_ssl},
            mail          => $self
        ) or return $self->error("SEND", "WARN", $GT::Mail::Send::error);
        $self->debug("\n\t<-------------- Email sent through SMTP") if $self->{_debug};
    }
    else {
        return $self->error("BADARGS", "FATAL", '$obj->send (%opts); smtp or sendmail and a head part must exist at this point.');
    }
    return $self;
}

sub top_part {
# -----------------------------------------------------------------------------
# $obj->top_part ($part);
# -----------------------
# This allows you to set the top level part directly.
# This is used to produce the email when sending or writing to file.
#
# my $top = $obj->top_part;
# -------------------------
# Returns the current top level part.
#

    my ($self, $part) = @_;
    if ($part and ref $part) {
        $self->{head} = $part;
    }
    return $self->{head};
}

sub new_part {
# -----------------------------------------------------------------------------
# $obj->new_part;
# ---------------
# $obj->new_part(
#     to      => 'user1@domain',
#     from    => 'user2@domain',
#     subject => 'Hi Alex',
#     type    => 'multipart/mixed',
#     ...
# );
# ---------------------------------
# Returns a new part. If arguments a given they are passed to the header method
# in the parts module. See the parts module for details.
#
    my $self = shift;

    my $part = new GT::Mail::Parts (debug => $self->{_debug}, header_charset => $self->{header_charset});
    $self->header($part, @_) if @_;
    return $part;
}

sub header {
# -----------------------------------------------------------------------------
# $obj->header(%header);
# ----------------------
# Mostly private method to set the arguments for the emails header.
# This is called by new and new_part.
# The options are:
#
#   disposition => Sets the Content-Disposition.
#   filename    => Sets the Content-Disposition to attachment and the
#                  file name to what to specify.
#   encoding    => Sets the Content-Transfer-Encoding (You really 
#                  should not set this).
#   header_charset => The header encoding charset.
#   type        => Sets the Content-Type.
#   body_data   => Sets the top level body data to the in memory string 
#                  specified.
#   msg         => Same as body_data.
#   body_handle => Sets the top level body to the File Handle.
#   body_path   => Sets the top level body path.
#

    my $self = shift;
    my $part = shift;

    my $opt;
    if (!@_) { return $self->error("BADARGS", "FATAL", '$obj->header(to => \'someone@somedomain\', from => \'someone@somedomain\');') }
    elsif (defined $_[0] and not @_ % 2) { $opt = {@_} }
    elsif (ref $_[0] and ref $_[0] eq 'HASH') { $opt = shift }
    else { return $self->error("BADARGS", "FATAL", '$obj->header(to => \'someone@somedomain\', from => \'someone@somedomain\');') }

    for my $tag (keys %{$opt}) {
        next unless defined $opt->{$tag};
        my $key = $tag;
        if    ($tag eq 'disposition') { $tag = 'Content-Disposition'            }
        elsif ($tag eq 'filename')    { $tag = 'Content-Disposition'; $opt->{$key} = 'attachment; filename="' . $opt->{$key} . '"' }
        elsif ($tag eq 'encoding')    { $tag = 'Content-Transfer-Encoding'      }
        elsif ($tag eq 'type')        { $part->mime_type($opt->{$tag}); next }
        elsif ($tag eq 'body_data')   { $part->body_data($opt->{$tag}); next }
        elsif ($tag eq 'header_charset') { $part->header_charset($opt->{$tag}); next }

# For Alex :)
        elsif ($tag eq 'msg')         { $part->body_data($opt->{$tag});   next }
        elsif ($tag eq 'body_handle') { $part->body_handle($opt->{$tag}); next }
        elsif ($tag eq 'body_path')   { $part->body_path($opt->{$tag});   next }
        $self->debug("Setting ($tag) to ($opt->{$key})") if ($self->{_debug} > 1);
        $part->set($tag => $opt->{$key});
    }
    return 1;
}

sub attach {
# -----------------------------------------------------------------------------
# $obj->attach($mail_object);
# ---------------------------
# Attaches an rfc/822 to the current email. $mail_object is a GT::Mail object.
#
# $obj->attach(
#     disposition  => 'inline',
#     type         => 'text/plain',
#     body_data    => 'Hello how are ya'
# );
# --------------------------------------
# Attaches the given data to the email. See header for a list of the options.
#
    my $self = shift;
    if (!$self->{head}) { return $self->error("NOEMAIL", "FATAL") }

    my $attach;
    if (ref $_[0] eq ref $self) {
        $self->debug("Adding rfc/822 email attachment.") if $self->{_debug};
        push @{$self->{mail_attach}}, @_;
        return 1;
    }
    elsif (ref $_[0] eq 'GT::Mail::Parts') {
        $attach = $_[0];
    }
    else {
        $attach = $self->new_part(@_);
    }
    $self->debug("Adding attachment.") if $self->{_debug};

# Guess the content-type if none was specified
    if (!$attach->mime_type and $attach->body_path) {
        (my $ext = $attach->body_path) =~ s/^.*\.//;
        $attach->mime_type(exists($CONTENT{$ext}) ? $CONTENT{$ext} : 'application/octet-stream');
    }
    $self->{head}->parts($attach);
    return 1;
}

sub to_string { shift->as_string }

sub as_string {
# --------------------------------------------------------------------------
# $obj->as_string;
# ----------------
# Returns the entire email as a sting. The parts will be encoded for sending at
# this point.
# NOTE: Not a recommended method for emails with binary attachments.
    my $self = shift;
    my $ret = '';
    $self->build_email(sub { $ret .= $_[0] });
    return $ret;
}

sub build_email {
    my ($self, $code) = @_;
    $GT::Mail::Encoder::CRLF = $CRLF;
# Need a code ref to continue.
    ref($code) eq 'CODE' or return $self->error("BADARGS", "FATAL", '$obj->build_email(sub {do something });');

    $self->debug("\n\t--------------> Creating email") if $self->{_debug};
# Need the head to contiue
    $self->{head} or return $self->error("NOEMAIL", "FATAL");
    unless ($self->{head}->get('MIME-Version')) { $self->{head}->set('MIME-Version', '1.0') }

    my $io    = $self->_get_body_handle($self->{head});
    my $bound = $self->{head}->multipart_boundary;

# If the message has parts

    if (@{$self->{head}->{parts}} > 0) {
        $self->debug("Creating multipart email.") if $self->{_debug};
        $self->_build_multipart_head($code, $io);
    }

# Else we are single part and have either a body IO handle or the body is in memory
    elsif (defined $io) {
        $self->debug("Creating singlepart email.") if $self->{_debug};
        $self->_build_singlepart_head($code, $io);
    }
    else {
        $self->error("NOBODY", "WARN");
        $code->($self->{head}->header_as_string . $CRLF . $CRLF . $GT::Mail::Parse::ENCODED);
    }

# If we have parts go through all of them and add them.
    if (@{$self->{head}->{parts}} > 0) {
        my $num_parts = $#{$self->{head}->{parts}};
        for my $num (0 .. $num_parts) {
            next unless $self->{head}->{parts}->[$num];
            $self->debug("Creating part ($num).") if $self->{_debug};
            $self->_build_parts($code, $self->{head}->{parts}->[$num]);
            if ($num_parts == $num) {
                $self->debug("Boundary\n\t--$bound--") if $self->{_debug};
                $code->($CRLF . '--' . $bound . '--' . $CRLF);
            }
            else {
                $self->debug("Boundary\n\t--$bound") if $self->{_debug};
                $code->($CRLF . '--' . $bound . $CRLF);
            }
        }
    }

# Add the epilogue if we are multipart
    if (@{$self->{head}->{parts}} > 0) {
        my $epilogue = join('', @{ $self->{head}->epilogue || [] }) || '';
        $epilogue =~ s/\015?\012//g;
        $self->debug("Setting epilogue to ($epilogue)") if $self->{_debug};
        $code->($epilogue . $CRLF . $CRLF) if $epilogue;
    }
    $self->debug("\n\t<-------------- Email created.") if $self->{_debug};
    return $self->{head};
}

sub write {
# --------------------------------------------------------------------------
# $obj->write ('/path/to/file');
# ------------------------------
# $obj->write (*FH);
# ------------------
# Writes the email to the specified file or file handle. The email will be
# encoded properly. This is nice for writing to an mbox file.  If a file path
# is specified this will attempt to open it >.  Returns 1 on success and undef
# on failure.
#
    my ($self, $file) = @_;
    my $io;
    if (ref($file) and (ref($file) eq 'GLOB') and fileno($file)) {
        $self->debug("Filehandle passed to write: fileno (" . fileno($file) . ").") if $self->{_debug};
        $io = $file;
    }
    elsif (open FH, ">$file") {
        $io = \*FH;
        $self->debug("Opening ($file) for reading.") if $self->{_debug};
    }
    else {
        return $self->error("BADARGS", "FATAL", '$obj->write ("/path/to/file"); -or- $obj->write (\*FH);');
    }
    $self->build_email(sub { print $io @_ }) or return;
    $self->debug("Email written to fileno (" . fileno($io) . ")") if $self->{_debug};
    return 1;
}

sub _set_io {
# --------------------------------------------------------------------------
# Private function to decide what to do with the arguments passed into parse
# and parse_head.
#
    my ($self, $io) = @_;

    CASE: {
        ref($io) eq 'SCALAR'                         and do { $self->{parser}->in_string($io); last CASE };
        ref($io) and ref($io) =~ /^GLOB|FileHandle$/ and do { $self->{parser}->in_handle($io); last CASE };
        -f $io                                       and do { $self->{parser}->in_file($io);   last CASE };
        ref $io                                      or  do { $self->{parser}->in_string($io); last CASE };
        return $self->error("NOIO", "FATAL");
    }
    return 1;
}

sub _encoding {
# --------------------------------------------------------------------------
# Private method to guess the encoding type.
#
    my ($self, $part) = @_;
    my $encoding;
    $encoding = $part->mime_attr('content-transfer-encoding');
    if ($encoding and lc($encoding) ne '-guess') {
        return $encoding;
    }
    else {
        return $part->suggest_encoding;
    }
}

sub date_stamp {
# --------------------------------------------------------------------------
# Set an RFC date, e.g.: Mon, 08 Apr 2002 13:56:22 -0700
#
    my $self = shift;
    require GT::Date;
    local @GT::Date::MONTHS_SH = qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
    local @GT::Date::DAYS_SH   = qw/Sun Mon Tue Wed Thu Fri Sat/;
    return GT::Date::date_get(time, '%ddd%, %dd% %mmm% %yyyy% %HH%:%MM%:%ss% %o%');
}

sub parse_address {
# -----------------------------------------------------------------------------
# Parses out the name and e-mail address of a given "address".  For example,
# from: "Jason Rhinelander" <jason@gossamer-threads.com>, this will return
# ('Jason Rhinelander', 'jason@gossamer-threads.com').  It handes escapes as
# well - "Jason \(\"jagerman\"\) Rhinelander" <jason@gossamer-threads.com>
# returns 'Jason ("jagerman") Rhinelander' for the name.
#
    my ($self, $email_from) = @_;

    my ($name, $email) = ('', '');
    if ($email_from =~ /"?((?:[^<"\\]|\\.)+?)"?\s*<([^>]*)>/) {
        ($name, $email) = ($1, $2);
        $name =~ s/\\(.)/$1/g;
        $name =~ s/^\s*$//;
    }
    elsif ($email_from =~ /<([^>]*)>/) {
        $email = $1;
    }
    else {
        $email = $email_from || '';
        $email =~ s/\([^)]+\)//g;
    }
    return ($name, $email);
}

sub _get_body_handle {
# --------------------------------------------------------------------------
# Private method to get a body handle on a given part.
#
    my ($self, $part) = @_;
    my $in = $part->body_in || 'NONE';
    my $io;
    if ($in eq 'MEMORY') {
        $self->debug("Body is in MEMORY.") if $self->{_debug};
        return $part->body_data;
    }
    elsif ($in eq 'FILE') {
        $self->debug("Body is in FILE: " . $part->body_path) if $self->{_debug};
        $io = $part->open('r');
    }
    elsif ($in eq 'HANDLE') {
        $self->debug("Body is in HANDLE.") if $self->{_debug};
        $io = $part->body_handle;
        binmode($io);
    }
    return $io;
}

sub _build_multipart_head {
# --------------------------------------------------------------------------
# Private method to build a multipart header.
#
    my ($self, $code, $io) = @_;
    my $bound = $self->{head}->multipart_boundary;
    my $encoding = $self->_encoding($self->{head});
    $self->debug("Setting encoding to ($encoding).") if $self->{_debug};
    $self->{head}->set(
        'Content-Transfer-Encoding' => $encoding
    );
    if (defined $io) {
        my $mime = 'text/plain';
        my ($type, $subtype) = split '/' => $self->{head}->mime_type;
        if ($type and lc($type) ne 'multipart') {
            $subtype ||= 'mixed';
            $mime = "$type/$subtype";
        }
        my %new = (
            type        => $mime,
            encoding    => $encoding,
            disposition => "inline"
        );

# Body is in a handle
        if (ref $io) { $new{body_handle} = $io }

# Body is in memory
        else { $new{body_data} = $io }

        my $new = $self->new_part(%new);
        $self->{head}->{body_in} = 'NONE';
        unshift @{$self->{head}->{parts}}, $new;
    }
    $bound ||= "---------=_" . time . "-$$-" . int(rand(time)/2);

# Set the content boundary unless it has already been set
    my $c = $self->{head}->get('Content-Type');
    if ($c !~ /\Q$bound/i) {
        if ($c and lc($c) !~ /boundary=/) {
            $c =~ /multipart/ or $c = 'multipart/mixed';
            $self->debug(qq|Setting content type to ($c; boundary="$bound")|) if $self->{_debug};
            $self->{head}->set('Content-Type' => $c . qq|; boundary="$bound"|);
        }
        else {
            $self->debug("Setting multipart boundary to ($bound).") if $self->{_debug};
            $self->{head}->set('Content-Type' => qq!multipart/mixed; boundary="$bound"!);
        }
    }

    my $preamble = join('', @{$self->{head}->preamble || []})
        || "This is a multi-part message in MIME format.";
    $preamble =~ s/\015?\012//g;
    $self->debug("Setting preamble to ($preamble).") if $self->{_debug};
    (my $head = $self->{head}->header_as_string) =~ s/\015?\012/$CRLF/g;
    $self->debug("Boundary\n\t--$bound") if $self->{_debug};
    $code->($head . $CRLF . $preamble . $CRLF . $CRLF . '--' . $bound . $CRLF);
    return 1;
}

sub _build_singlepart_head {
# --------------------------------------------------------------------------
# Private method to build a single part header.
#
    my ($self, $code, $io) = @_;
    my $encoding = $self->_encoding($self->{head});
    $self->debug("Setting encoding to ($encoding).") if $self->{_debug};
    $self->{head}->set('Content-Transfer-Encoding' => $encoding);
    (my $head = $self->{head}->header_as_string) =~ s/\015?\012/$CRLF/g;
    $code->($head . $CRLF);
    $self->debug("Encoding body with ($encoding).") if $self->{_debug};
    GT::Mail::Encoder->gt_encode(
        debug    => $self->{_debug},
        encoding => $encoding,
        in       => $io,
        out      => $code
    ) or return $self->error("ENCODE", "WARN", $GT::Mail::Encoder::error);

# Must seek to the beginning for additional calls
    seek($io, 0, 0) if ref $io;
    return 1;
}

sub _build_parts {
# --------------------------------------------------------------------------
# Private method that builds the parts for the email.
#
    my ($self, $code, $part) = @_;

# Need a code ref to continue.
    ref($code) eq 'CODE' or return $self->error("BADARGS", "FATAL", '$obj->build_email(sub { do something });');

# Need the head to contiue
    $self->{head} or return $self->error("NOEMAIL", "FATAL");

    my ($body, $io, $encoding, $bound);

# Get the io handle for the body
    $io    = $self->_get_body_handle($part);
    $bound = $part->multipart_boundary;

# The body is in an io stream.
    if (defined $io) {

# Find the encoding for the part and set it.
        $encoding = $self->_encoding($part);
        $self->debug("Setting encoding to ($encoding).") if $self->{_debug};
        $part->set('Content-Transfer-Encoding' => $encoding);
    }

# If the message has parts and has a multipart boundary
    if ((@{$part->{parts}} > 0) and ($bound)) {
        $self->debug("Part is multpart.") if $self->{_debug};

# Set the multipart boundary
        $self->debug("Setting boundary to ($bound).") if $self->{_debug};

# Set the content boundary unless it has already been set
        my $c = $part->get('Content-Type');
        if ($c) {
            $self->debug(qq|Setting content type to ($c; boundary="$bound")|) if $self->{_debug};
            $part->set('Content-Type' => $c . qq|; boundary="$bound"|);
        }
        else {
            $self->debug("Setting multipart boundary to ($bound).") if $self->{_debug};
            $part->set('Content-Type' => qq!multipart/mixed; boundary="$bound"!);
        }

        my $preamble = join('', @{$part->preamble || []})
            || "This is a multi-part message in MIME format.";
        $preamble =~ s/\015?\012//g;
        $self->debug("Setting preamble to ($preamble).") if $self->{_debug};
        (my $head = $part->header_as_string) =~ s/\015?\012/$CRLF/g;
        $self->debug("Boundary\n\t--$bound") if $self->{_debug};
        $code->($head . $CRLF . $preamble  . $CRLF . '--' . $bound . $CRLF);
    }
    else {
        $self->debug("Part is single part.") if $self->{_debug};
        (my $head = $part->header_as_string) =~ s/\015?\012/$CRLF/g;
        $code->($head . $CRLF);
    }

# Set the body only if we have one. We would not have one on the head an multipart
    if ($io) {
        $self->debug("Encoding body with ($encoding).") if $self->{_debug};
        GT::Mail::Encoder->gt_encode(
            encoding => $encoding,
            debug    => $self->{_debug},
            in       => $io,
            out      => $code
        ) or return $self->error("ENCODE", "WARN", $GT::Mail::Encoder);

# Must reseek IO for multiple calls.
        seek($io, 0, 0) if ref $io;
    }
    else {
        $self->debug("Part has no body!") if $self->{_debug};
    }

# Add the rest of the parts
    if (@{$part->{parts}} > 0) {
        $self->debug("Part has parts.") if $self->{_debug};
        my $num_parts = $#{$part->{parts}};
        for my $num (0 .. $num_parts) {
            next unless $part->{parts}->[$num];
            $self->debug("Creating part ($num).") if $self->{_debug};
            $self->_build_parts($code, $part->{parts}->[$num]) or return;
            if ($bound) {
                if ($num_parts == $num) {
                    $self->debug("Boundary\n\t--$bound--") if $self->{_debug};
                    $code->($CRLF . '--' . $bound . '--' . $CRLF);
                }
                else {
                    $self->debug("Boundary\n\t--$bound") if $self->{_debug};
                    $code->($CRLF . '--' . $bound . $CRLF);
                }
            }
        }
    }

    undef $io;
    return 1;
}

1;

__END__

=head1 NAME

GT::Mail - A simple interface to parsing, sending, and creating email.

=head1 SYNOPSIS

    use GT::Mail;
 
    # Create and Sending
    GT::Mail->send(
        smtp      => 'gossamer-threads.com',
        smtp_port => 110, # optional; 110/465 (normal/SSL) will be used for the default
        smtp_ssl  => 1, # establish an SSL connection.  Requires Net::SSLeay 1.06 or newer.
        to        => 'scott@gossamer-threads.com',
        from      => 'scott@gossamer-threads.com',
        subject   => 'Hello!!',
        msg       => 'I am a text email'
    ) or die "Error: $GT::Mail::error";
 
    # Parsing and sending
    my $mail = GT::Mail->new(debug => 1);

    # Parse an email that is in a file called mail.test
    my $parser = $mail->parse('mail.test') or die "Error: $GT::Mail::error"; 
     
    # Change who it is to
    $parser->set("to", 'scott@gossamer-threads.com');

    # Add an attachment to it
    $mail->attach (
        type      => 'text/plain',
        encoding  => '-guess',
        body_path => 'Mail.pm',
        filename  => 'Mail.pm'
    );
 
    # Send the email we just parsed and modified
    $mail->send(sendmail => '/usr/sbin/sendmail') or die "Error: $GT::Mail::error";

=head1 DESCRIPTION

GT::Mail is a simple interface for parsing, creating, and sending email. It
uses GT::Mail::Send to send email and GT::Mail::Parse to parse and store email
data structurs. All the creation work is done from within GT::Mail.

=head2 Creating a new GT::Mail object

The arguments to new() in GT::Mail are mostly the same for all the class
methods in GT::Mail so I will be refering back to these further down.  Mostly
these arguments are used to set parts of the header for creating an email. The
arguments can be passed in as either a hash or a hash ref. Any arguments aside
from these will be added to the content header as raw header fields. The
following is a list of the keys and a brief description.

=over 4

=item debug

Sets the debug level for this object. Anything but zero will produce ouput on
STDERR.

=item disposition 

Sets the Content-Disposition.

=item filename    

Sets the Content-Disposition to attachment and the file name to what to
specify.

=item encoding    

Sets the Content-Transfer-Encoding (You really should not set this).

=item type        

Sets the Content-Type.

=item body_data

Sets the top level body data to the in memory string specified.

=item msg

Same as body_data.

=item body_handle

Sets the top level body to the File Handle.

=item body_path

Sets the top level body path. 

=back

=head2 parser - Set or get the parse object.

    my $parser = $mail->parser;
    $mail->parser($parser);

Set or get method for the parser object that is used when you call parse_head()
or parse(). This object must conform to the method parse and parse_head. If no
object is passed to this method a L<GT::Mail::Parse> object is created when
needed.

=head2 parse - Parsing an email.

Instance method that returns a parts object. Emails are stored recursivly in
parts object. That is emails can have parts within parts within parts etc.. See
L<GT::Mail::Parts> for details on the methods supported by the parts object
that is returned.

The parse() method takes only one argument. It can be a GLOB ref to a file
handle, a FileHandle object, or the path to a file. In any case the IO must
contain a valid formated email.

Once an email is parsed, you can make changes to it as you need and call the
send method to send it or call the write method to write it to file, etc.

This method will return false if an error occurs when parsing.  The error
message will be set in $GT::Mail::error.

=head2 parse_head - Parsing just the head.

This method does the exact same thing as the parse method but it will only
parse the top level header of the email. Any IO's will be reset after the
parsing.

Use this method if whether you want to parse and decode the body of the email
depends on what is in the header of the email or if you only need access to the
header. None of the parts will contain a body.

=head2 send - Sending an email.

Class/Instance method for sending email. It sends the currently in memory
email. This means, if you parse an email, that email is in memory, if you
specify params for an email to new(), that is the email that gets sent. You can
also specify the params for the email to this method.

=head2 top_part - Getting a Parts object.

Instance method to set or get the top level part. If you are setting this, the
object must be from L<GT::Mail::Parts>. You can use this to retrieve the part
object after you specify params to create an email. This object will contain
all the other parts for the email.  e.g. attachments and emails that are
attached. See L<GT::Mail::Parts> for more details on this object.

=head2 new_part - Creating a Parts object.

Instance method to get a new part object. This method takes the same arguments
as the new() constructor. Returns the new part object.  The part object is
added to the current email only if arguments are given otherwize just returns
an empty part.

=head2 attach - Attaching to an email.

Instance method to attach to the in memory email. You can pass in a GT::Mail
object or you can pass the same arguments you would pass to new() to specify
all the information about the attachment. In addition if you specify a file
path and do not specify a mime type, this will attempt to guess the mime type
from the file extention.

=head2 to_string - Getting the email as a string.

Returns the entire email as a string. Do not use this function if you have
attachments and are worried about memory ussage.

=head2 as_string - Getting the email as a string.

Same as to_string.

=head2 build_email - Building an email.

Instance method that builds the currently in memory email. This method takes
one argument, a code ref. It calles the code ref with one argument.  The code
ref is called for each section of the email that is created.  A good example of
how to use this is what the as_string method does:

    my $ret = '';
    $obj->build_email(sub { $ret .= $_[0] });

This puts the entire created email into the string $ret. You can use this, for
example to print the email to a filehandle (which is what the write() method
does).

=head2 write - Writing an email to a file handle.

Instance mothod that writes the currently in memory email to a file or file
handle. The only arguments this method takes is a file or a reference to a glob
that is a filehandle or FileHandle object.

=head2 naming - Setting the naming scheme.

Instance method to specify a naming scheme for parsing emails. Calling this
after the email is parsed has no effect. This method just wraps to the one in
L<GT::Mail::Parse>.

=head1 COPYRIGHT

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

=head1 VERSION

Revision: $Id: Mail.pm,v 1.70 2004/11/04 20:23:09 brewt Exp $

=cut
