File Coverage

blib/lib/Mail/Header/Generator.pm

Criterion	Covered	Total	%
statement	77	78	98.7
branch	38	46	82.6
condition	12	17	70.5
subroutine	10	10	100.0
pod	5	5	100.0
total	142	156	91.0

package Mail::Header::Generator;
use warnings;
use strict;

use Time::Local ();

=head1 NAME

Mail::Header::Generator - Generate various email headers.

=head1 VERSION

Version 0.200

=cut

our $VERSION = '0.301';

=head1 SYNOPSIS

    use Mail::Header::Generator ();

    my $gen = Mail::Header::Generator->new({
	hostname      => 'foobar.example.com',
    });

    # Generate Message-Id: header contents.  $message_id will
    # contain:
    # 	<[e-mail]>
    # and use the hostname provided to the constructor.
    my $message_id = $gen->message_id({
        timestamp => time(),
	queue_id  => 'GA9035',
    });

    # Generate a Received: header, including the Received: name.
    # Will result in something similar to:
    #   Received: from localhost.localdomain ([127.0.0.1] localhost)
    #   	by foobar.example.com with ESMTP id o53JaiwX007246; Thu, 03 Jun 2010 15:37:51 -0400
    my $received   = $gen->received({
	header_name    => undef,
	relay_address  => '127.0.0.1',
	relay_hostname => 'localhost',
	helo           => 'localhost.localdomain',
	protocol       => 'ESMTP',
	queue_id       => 'o53JaiwX007246',
    });

=head1 DESCRIPTION

This class generates RFC 5321/5322-compliant headers for use in
email messages.

=head1 METHODS

=head2 Class Methods

=over 4

=item new ( { args } )

Constructs a new Mail::Header::Generator.

Takes a hash reference containing default arguments to be used for the various
header-generation callbacks.

Commonly useful keys for default arguments are:

=over 4

=item timestamp

A UNIX timestamp (from time()).

=item hostname

The local host name.

=item queue_id

The queue ID for the message you're generating these headers for.

=back

=cut

sub new
{
	my ($class, $args) = @_;

	# Yeah, yeah....  Should be using a real base class
	my $self = { %{ $args || {} } };

	return bless $self, $class;
}

# Return instance data overridden by args, if we're called on an instance.
# Return args if we're called on the class
sub _header_data
{
	my ($referent, $args) = @_;
	$args ||= {};

	if( ref $referent ) {
		return (%$referent, %$args)
	}

	return %$args;
}

=pod

=back

=head2 Common Parameters

The following methods all take named parameters (as a hash reference).  The
following parameters are common:

=over 8

=item header_name

The name of this header.  If this key exists and has a value of undef, the
contents of the generated header will be returned with no name prefixed.  If
the key exists, and has a value, that value will be used as the name.  If the
key does not exist, the header will default to the same name as the method used
to create it.

=item timestamp

UNIX timestamp (as generated by time()) for this header.  If not provided,
defaults to the current value of time().

=item hostname

The local host name.

=back

=head2 Instance Methods

=over 4

=item message_id ( ... )

Returns a string containing a Message-ID header.

Takes a hash reference containing values to use in generating this header.
Valid keys are:

=over 4

=item header_name

Defaults to 'Message-ID' if not provided.

=item timestamp

=item hostname

=back

See top of this section for further details on these parameters.

=cut

sub message_id
{
	my ($referent, $args) = @_;

	# $args can override values from $referent
	my %data = $referent->_header_data( $args );

	$data{timestamp} ||= time();
	$data{hostname}  ||= 'localhost';
	$data{header_name} = 'Message-ID' unless exists $data{header_name};

	my ($ss, $mm, $hh, $mday, $mon, $year, $wday, $yday, $isdst) = localtime($data{timestamp});

	# Generate a "random" message ID, similar in format to Sendmail-generated IDs
	return sprintf('%s<%04d%02d%02d%02d%02d.%s@%s>',
		($data{header_name} ? "$data{header_name}: " : ''),
		$year + 1900,
		$mon  + 1,
		$mday,
		$hh,
		$mm,
		($data{queue_id} ? $data{queue_id} : sprintf('%06d',int(rand(1000000)))),
		$data{hostname},
	);
}

=item received ( ... )

Returns a string containing a Received header.

Takes a hash reference containing values to use in generating this header.
Valid keys are:

=over 4

=item header_name

Defaults to 'Received' if not provided.

=item timestamp

=item hostname

=item product_name

String containing name of product responsible for adding this header.  Will be
added as a comment in the generated header if present.

=item protocol

Protocol this message was received over.  Should be "SMTP" or "ESMTP" for
standards compliance.  Will not be used in the generated header if not
provided.

=item recipients

An array reference of recipient addresses.  Currently, a 'for' tag will be created as
part of the header only if the recipients array contains a single address.

=item relay_address

String representation of IPv4 or IPv6 address that relayed this message to us.
If not present, no 'from' section of the header will be created.

=item relay_hostname

Hostname of relay address.

=item sender

The envelope sender address.  If present, an 'envelope-sender' comment will be
added to the generated header.

=item user

Local user that generated this message.  Defaults to $ENV{USER} if not present
and no relay address was provided.

=back

See top of this section for further details on these parameters.


=cut

sub received
{
	my ($referent, $args) = @_;

	# $args can override values from $referent
	my %data = $referent->_header_data( $args );

	$data{user} = $ENV{USER} unless exists $data{user};
	$data{user} = 'unknown'  unless $data{user};
	$data{protocol}  ||= '';
	$data{timestamp} ||= time();
	$data{recipients}  = []         unless exists $data{recipients};
	$data{header_name} = 'Received' unless exists $data{header_name};

	my $header = '';
	$header .= "$data{header_name}: " if defined $data{header_name};

	# TODO: should escape our data for anything that could cause a
	# problem in a () comment.

	# Add relay address, if we have one
	if($data{relay_address}) {
		$header .= 'from';
		# TODO: helo needs cleansing, blow away non-ASCII-printable?
		$header .= " $data{helo}" if exists $data{helo};
		my $relay_info = "[$data{relay_address}]";
		if($data{relay_hostname} ne $relay_info) {
			$relay_info = "$data{relay_hostname} $relay_info";
		}
		$header .= " ($relay_info)";
	} else {
		$header .= "(from $data{user}\@localhost)";
	}

	if($data{hostname}) {
		$header .= "\n\tby " . $data{hostname};
		if($data{protocol} =~ /e?smtp/i && $data{sender}) {
			# TODO: sanitize envelope sender?
			$header .= " (envelope-sender <$data{sender}>)";
		}
	}

	if($data{product_name}) {
		$header .= " ($data{product_name})";
	}

	if($data{protocol} =~ /e?smtp/i) {
		$header .= ' with ' . uc($data{protocol});
	}

	if( $data{queue_id} ) {
		$header .= ' id ' . $data{queue_id};
	}

	# If more than one recipient, don't specify to protect privacy
	if(scalar @{ $data{recipients} } == 1) {
		$header .= "\n\tfor <" . $data{recipients}->[0] . '>';
	}

	$header .= '; '
	  . $referent->rfc2822_date({
			header_name => undef,
			timestamp   => $data{timestamp}
	});

	return $header;
}

=item rfc2822_date ( ... )

Returns a string containing a RFC 2822 formatted date.

Takes a hash reference containing values to use in generating this header.
Valid keys are:

=over 4

=item header_name

No default if not provided.

=item timestamp

UNIX timestamp.  Defaults to current value of time() if not provided.

=back

=cut

# _tz_diff and rfc2822_date borrowed from Email::Date.  Why?
# Because they depend on Date::Parse and Time::Piece, and I don't want
# to add them as dependencies.
# Similar functions exist in MIMEDefang as well
sub _tz_diff
{
	my ($time) = @_;

	my $diff = Time::Local::timegm(localtime $time) - Time::Local::timegm(gmtime $time);

	my $direc = $diff < 0 ? '-' : '+';
	$diff = abs $diff;
	my $tz_hr = int($diff / 3600);
	my $tz_mi = int($diff / 60 - $tz_hr * 60);

	return ($direc, $tz_hr, $tz_mi);
}

=item date ( ... )

Returns a date header containing a RFC 2822 formatted date.  This is a
convenience wrapper around rfc2822_date().

Takes a hash reference containing values to use in generating this header.
Valid keys are:

=over 4

=item header_name

Defaults to 'Date' if not provided.

=item timestamp

UNIX timestamp.  Defaults to current value of time() if not provided.

=back

=cut

sub date
{
	my ($referent, $args) = @_;

	$args ||= {};

	$args->{header_name} = 'Date' unless exists $args->{header_name};

	return $referent->rfc2822_date($args);
}

sub rfc2822_date
{
	my ($referent, $args) = @_;

	# $args can override values from $referent
	my %data = $referent->_header_data( $args );

	$data{timestamp} = time unless exists $data{timestamp};

	my ($sec, $min, $hour, $mday, $mon, $year, $wday) = localtime $data{timestamp};
	my $day   = (qw[Sun Mon Tue Wed Thu Fri Sat])[$wday];
	my $month = (qw[Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec])[$mon];
	$year += 1900;

	my ($direc, $tz_hr, $tz_mi) = _tz_diff($data{timestamp});

	return
	  sprintf "%s%s, %d %s %d %02d:%02d:%02d %s%02d%02d",
	  (defined $data{header_name} ? "$data{header_name}: " : ''),
	  $day, $mday, $month, $year, $hour, $min, $sec, $direc, $tz_hr, $tz_mi;
}

=pod

=back

=head1 AUTHOR

Dave O'Neill,

=head1 BUGS

Please report any bugs or feature requests to C, or through
the web interface at L.  I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Mail::Header::Generator


You can also look for information at:

=over 4

=item * RT: CPAN's request tracker

L

=item * Search CPAN

L

=back

=head1 ACKNOWLEDGEMENTS

received() and message_id() were originally implemented in MIMEDefang.

rfc2822_date() implementation based on one from Email::Date.

=head1 LICENSE AND COPYRIGHT

Copyright 2010 Roaring Penguin Software

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; version 2 dated June, 1991 or at your option
any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

A copy of the GNU General Public License is available in the source tree;
if not, write to the Free Software Foundation, Inc.,
59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

=cut

1;  # End of Mail::Header::Generator