989 lines
36 KiB
Perl
989 lines
36 KiB
Perl
# ==================================================================
|
|
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
|
#
|
|
# GT::Mail
|
|
# Author : Scott Beck
|
|
# CVS Info : 087,071,086,086,085
|
|
# $Id: Mail.pm,v 1.77 2007/08/01 23:35:15 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.77 $ =~ /(\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->{smtp_helo} = delete $opt->{smtp_helo} || '';
|
|
$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 [, eol-sequence]);
|
|
# -----------------------------------
|
|
# $obj->parse('/path/to/file' [, eol-sequence]);
|
|
# ----------------------------------------------
|
|
# $obj->parse($SCALAR_REF -or- $SCALAR [, eol-sequence]);
|
|
# -------------------------------------------------------
|
|
# Takes a path to a file, file handle, scalar or scalar reference containing
|
|
# the e-mail, and optionally a second argument specifying the EOL sequence to
|
|
# use when parsing (defaults to "\n" - corresponds directly to the
|
|
# GT::Mail::Parse crlf method).
|
|
# Returns head part 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, $eol) = @_;
|
|
|
|
# Require our parser
|
|
require GT::Mail::Parse;
|
|
|
|
# Get a new parser object
|
|
$self->{parser} ||= new GT::Mail::Parse (debug => $self->{_debug});
|
|
$self->{parser}->crlf($eol) if $eol;
|
|
$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 [, eol-sequence]);
|
|
# -----------------------------------------
|
|
# $obj->parse_head ('/path/to/file' [, eol-sequence]);
|
|
# ----------------------------------------------------
|
|
# 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, $eol) = @_;
|
|
|
|
# Require our parser
|
|
require GT::Mail::Parse;
|
|
|
|
# Get a new parser object
|
|
$self->{parser} ||= new GT::Mail::Parse (debug => $self->{_debug});
|
|
$self->{parser}->crlf($eol) if $eol;
|
|
$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},
|
|
helo => $self->{smtp_helo},
|
|
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 continue
|
|
$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);
|
|
}
|
|
|
|
# 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 defined 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;
|
|
select((select($io), $| = 1)[0]);
|
|
$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 or $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
|
|
if (my $c = $part->get('Content-Type')) {
|
|
unless ($c =~ /;\s*boundary="\Q$bound\E"/i) {
|
|
$self->debug(qq|Setting content type to ($c; boundary="$bound")|) if $self->{_debug};
|
|
$part->set('Content-Type' => qq{$c; 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.77 2007/08/01 23:35:15 brewt Exp $
|
|
|
|
=cut
|