#!/usr/bin/perl -w
use strict;

# $Id: mime-construct,v 1.9 2001/04/07 03:02:45 roderick Exp $
#
# Roderick Schertler <roderick@argon.org>

# Copyright (C) 1999 Roderick Schertler
#
# 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; either version 2 of the License, 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.
#
# For a copy of the GNU General Public License write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA

# XXX
#    - use mime.types to default the type for files, idea from PerlJam
#    - don't always load bodies into memory?
#    - continue long header lines I construct

use Proc::WaitStat qw(close_die);

(my $Me = $0) =~ s-.*/--;
my # new line required for makemaker
    $VERSION = '1.8';

my $Debug	= 0;
my $Exit	= 0;

my $Usage = <<EOF;
usage: $Me switch...

  Global settings:
    --debug		turn debugging on
    --help		show this and then die
    --output		don\'t mail, output to stdout (loses bcc info)
    --subpart		generate subpart rather than whole message (turns
    	    	    	on --output, changes other semantics a bit)
    --version		show the version number and exit (by itself only)

  Main header, can appear anywhere:
    --bcc address	add a bcc recipient
    --cc address	add a cc recipient
    --embedded-to	send to recipients already listed in the header
    --header x		add arbitrary primary headers
    --multipart x	specify multipart content type and options
    --prelude x		add to multipart prelude text
    --subject x		specify subject
    --to address	add a to recipient

  Per-part header, only affects next part output:
    --attachment name	specify attachment disposition with given file name
    --encoding x	specify encoding for next part
    --part-header x	add arbitrary headers for next part
    --type x		specify content type for next part

  Part output switches:
    --file path		output a part whose contents come from path
    --string str	output a part whose contents are str

  Subpart output switches:
    --subpart-file path
    --subpart-string str
    	Same as previous two, but path or str contains a subpart.  It can
    	contains headers, and you can't specify a --type or --encoding for
    	it here (they should be supplied when it is generated).  Normally
    	it will have been generated by $Me with the --subpart switch.

The default content type is text/plain.  The default encoding is chosen
based on the body.  The default multipart type is multipart/mixed.

See the man page or \`perldoc $Me\' for the full documentation.
EOF

# Alphabet for random boundary strings, used only if it looks like none
# of the words will work.  These must all be valid boundary chars, they
# aren't vetted.
my @Alphabet = ('a'..'z');

# Words for boundary strings.  These must all be composed of valid
# boundary chars, they aren't vetted.
my @Word = qw(
    amon-hen angband aragorn azog baggins balin balrog barad-dur
    beleriand beren bilbo bombadil boromir cirith-ungol deagol dirhavel
    dol-guldur doriath durin earendil ecthelion elbereth elrond fangorn
    faramir feanor finarfin frodo galadriel gamgee gandalf gollum gondor
    gorgoroth iluvatar imladris isengard isildur ithilien lothlorien
    luthien minas-morgul minas-tirith mordor morgoth moria nargothrond
    nauglamir nazgul numenor orthanc osgiliath palantir pengolodh
    rivendell rohirrim samwise saruman sauron silmaril thangorodrim
    theoden thranduil thror uruk-hai valar voronwe weathertop

    abalone aborigine addressee admonition aerodynamic affidavits
    algonquin animators apprentice astonishing ballyhoo baltimorean
    barometric blackbird brouhaha butterers calvinball chandeliers
    comparator computerizes conductance congratulations consecrate
    constellations continual controllability courtesan cranberry
    crusading culturally curtained dartmouth daugherty deleterious
    detestable disambiguations dragonhead envisages excursions explainer
    extension fluctuations freudianism greentree harbinger
    inadequateness indoctrination inexcusably interpersonal
    intramuscular irrational jealousies latinized liberators louisville
    loveliness lutheranizer luxurious malfunctioning manhattanize
    marionette marlinspike masterfully meistersinger monochromatic
    monograph multiplier mustiness nationalizing navigating negligent
    nicaragua normanizers parallelism passivate percentile perfuming
    pigmented plexiglas procrusteanizes protestantism pterodactyl
    purportedly quinoa rachmaninoff recalibrates reciprocates
    referentiality regeneration reminiscently repudiates resynchronizing
    revisiting rigorously sanderling satisfiable saxonizations
    scampering scarceness sclerotic smokestack steelmaker stegosaurus
    stipulating telegraphing thirtieth transparently tunafish
    unaesthetically unattainability uncoordinated uncountably underflow
    unrepresentable unthinkable ventricles whitehall
);

sub xwarndie_mess {
    my @mess = ("$Me: ", @_);
    $mess[$#mess] =~ s/:(?!\n)$/: $!\n/;
    return @mess;
}

sub xdie {
    die xwarndie_mess @_;
}

sub xwarn {
    warn xwarndie_mess @_;
    $Exit ||= 1;
}

sub usage {
    xwarn @_ if @_;
    die $Usage;
}

sub init {
    srand;
}

# Perform header continuation on STRING and return the result.

sub cont {
    my $s = join '', @_;
    $s =~ s/\n(\S)/\n\t$1/g;
    return $s;
}

# Quote STRING as a MIME token and return the result.

sub token_quote {
    my $s = shift;
    # XXX Characters \200-\377 aren't actually valid.
    if ($s =~ /[\040\000-\037\177\200-\377()<>@,;:\\\"\/\[\]?=]/) {
	$s =~ s/([\"\015\\])/\\$1/g;
	$s = qq["$s"];
    }
    return $s;
}

# Choose an appropriate encoding for STRING and return it.  If DESCRIBE_ONLY
# is given, don't suggest an encoding that would actually change the data,
# just return an encoding appropriate for what the data already is.

sub choose_encoding {
    my ($s, $describe_only) = @_;

    return '7bit' if $s eq '';

    # Use 7bit if possible.
    return '7bit' if $s !~ /[^\011\012\040-\176]/	# valid chars
			&& $s =~ /\n\Z/			# trailing \n
			&& $s !~ /[ \t]\n/		# no trailing spaces
    	    	    	&& $s !~ /^.{81,}$/m;		# no long lines

    # If requested, just classify other data as either 8bit or binary,
    # don't suggest an actual encoding for it.
    if ($describe_only) {
	return '8bit' if $s !~ /[\x00\x0d]/		# no nulls or CRs
			    && $s !~ /^.{999,}/m;	# no long lines
    	return 'binary';
    }

    # QP can't represent a bytestream which lacks a trailing newline.
    return 'base64' unless $s =~ /\n\Z/;

    # Use QP if it's mostly ASCII.
    my $n = $s =~ tr/\000-\010\013-\037\200-\377//;
    return 'quoted-printable' if $n / length($s) < 0.25;

    return 'base64';
}

# Given HER_ENCODING and STRING, encode and return the string (choosing
# an encoding if none is specified).

sub encode {
    my ($encoding, $s) = @_;
    my ($lc_encoding);

    $encoding = choose_encoding $s if $encoding eq '';
    $lc_encoding = lc $encoding;

    if ($lc_encoding =~ /^(7bit|8bit|binary)$/) {
	# do nothing
    }
    elsif ($lc_encoding eq 'quoted-printable') {
	require MIME::QuotedPrint;
	$s = MIME::QuotedPrint::encode($s);
    }
    elsif ($lc_encoding eq 'base64') {
	require MIME::Base64;
	$s = MIME::Base64::encode($s);
    }
    else {
	xdie "invalid encoding $encoding\n";
    }

    return $encoding, $s;
}

# Given REF (a reference to an array of strings) and SUBSTRING, return
# false if the substring appears in any of the strings.

sub try_boundary {
    my ($rpart, $boundary) = @_;

    for (@$rpart) {
	return 0 if index($_, $boundary) >= 0;
    }
    return 1;
}

# Given REF (a reference to an array of strings), return a string which
# doesn't appear in any of the strings.

sub choose_boundary {
    my ($rpart) = @_;

    # Try words from the built in dictionary to avoid yucky random
    # boundary strings.  NB:  This is destructive to @Word.
    for (my $try = 0; $try < 100 && @Word; $try++) {
	my $word = splice @Word, rand @Word, 1;
	if (try_boundary $rpart, $word) {
	    return $word;
	}
    }

    # That failed, she's probably mailing me.  Fall back to randomness.
    for (my $try = 0; $try < 100; $try++) {
	my $word = join '', map { $Alphabet[rand @Alphabet] } 0..9;
	if (try_boundary $rpart, $word) {
	    return $word;
	}
    }

    xdie "can't find a reasonable boundary\n";
}

sub process {
    my @args = @_;

    if (@args == 1 && $args[0] eq '--version') {
	print "$Me $VERSION\n";
	return 0;
    }

    my ($switch, $arg, $subject, @to, @cc, @bcc, $header, $part_header,
	$output, $subpart, $embedded_to, $encoding, @part, $type,
	@output, $multipart, $multipart_encoding, @recip, $prelude);

    $output = 0;
    $subpart = 0;
    $embedded_to = 0;
    $subject = '';
    $header = '';
    $prelude = '';

    $multipart = 'multipart/mixed';
    $multipart_encoding = '7bit';

    # per-part
    $encoding = $part_header = $type = undef;

    while (@args) {
    	$switch = shift @args;

	$switch =~ /^-/ or usage "invalid arg (non-switch) $switch\n";

	# switches which don't take args
    	if ($switch eq '--debug') {
	    $Debug = 1;
	    next;
	}
	elsif ($switch eq '--help') {
    	    usage;
	    # not reached
	    next;
	}
	elsif ($switch eq '--output') {
	    $output = 1;
	    next;
	}
	elsif ($switch eq '--subpart') {
	    $subpart = $output = 1;
	    next;
	}
	elsif ($switch eq '--embedded-to') {
	    $embedded_to = 1;
	    next;
	}
	elsif ($switch eq '--version') {
	    print "$Me $VERSION\n";
	    xdie "--version specified with other switches\n";
	}

	# switches which do take args
	@args or xdie "invalid trailing arg (invalid switch or arg needed) ",
	    	    	"$switch\n";
	$arg = shift @args;
	if ($switch eq '--attachment') {
	    $part_header .= "Content-Disposition: attachment; filename="
    	    	    	    . token_quote($arg) . "\n";
	}
	elsif ($switch eq '--bcc') {
	    push @bcc, $arg;
	}
	elsif ($switch eq '--cc') {
	    push @cc, $arg;
	}
	elsif ($switch eq '--encoding') {
	    $encoding = $arg;
	}
	elsif ($switch eq '--header') {
	    $header .= $arg;
	    $header .= "\n" unless $header =~ /\n\Z/;
	}
	elsif ($switch eq '--multipart') {
	    $multipart = $arg;
	}
	elsif ($switch eq '--part-header') {
	    $part_header .= $arg;
	    $part_header .= "\n" unless $part_header =~ /\n\Z/;
	}
	elsif ($switch eq '--prelude') {
	    $prelude .= $arg;
	    $prelude .= "\n" unless $prelude =~ /\n\Z/;
	}
	elsif ($switch eq '--subject') {
	    $subject = $arg;
	}
	elsif ($switch eq '--to') {
	    push @to, $arg;
	}
	elsif ($switch eq '--type') {
	    $type = $arg;
	}

	elsif ($switch eq '--file' || $switch eq '--string'
		|| $switch eq '--subpart-file'
		|| $switch eq '--subpart-string') {
	    my ($is_sub, $body, $actual_encoding);
	    $is_sub = ($switch =~ s/^--subpart-/--/);
	    if ($switch eq '--string') {
		$body = $arg;
	    }
	    else {
		require FileHandle;
		# This will work with an arbitrarily weird file name,
		# but it will also allow 'zcat file.gz|' to work.
		my $fh = FileHandle->new($arg, 'r')
			    || FileHandle->new($arg)
			    || xdie "can't read $arg:";
		{
		    local $/;
		    $body = <$fh>;
		}
		close_die $fh, $arg;
	    }

	    my $p = defined $part_header ? $part_header : '';

	    if ($is_sub) {
		for ([$encoding, 'an encoding'], [$type, 'a type']) {
		    defined $_->[0]
			and xdie "can't specify $_->[1] for input subparts\n";
		}
		$actual_encoding = choose_encoding $body, 1;
	    }
	    else {
		$encoding	= ''		unless defined $encoding;
		$type		= 'text/plain'	unless defined $type;

		($actual_encoding, $body) = encode $encoding, $body;
		$p .= cont "Content-Type: $type\n"
		    unless $type =~ m|^\s* text/plain
					(?:\s* ; \s* charset=(\")?us-ascii\1)?
					\s*$|xi;
		$p .= cont "Content-Transfer-Encoding: $actual_encoding\n"
		    unless lc($actual_encoding) eq '7bit';
		$p .= "\n";
	    }

	    if (lc($actual_encoding) eq 'binary') {
		$multipart_encoding = 'binary';
	    }
	    elsif (lc($actual_encoding) eq '8bit') {
		$multipart_encoding = '8bit'
		    unless $multipart_encoding eq 'binary';
	    }

	    $p .= $body;
	    push @part, $p;

	    $encoding = $part_header = $type = undef;
	}

	else {
	    xdie "invalid switch $switch\n";
	}
    }

    defined $encoding		and xdie "useless trailing --encoding\n";
    defined $part_header	and xdie "useless trailing --part-header\n";
    defined $type		and xdie "useless trailing --type\n";
    # Don't choke if --prelude was specified but it turned out not to be
    # multipart, that's allowed.

    @recip = (@to, @cc, @bcc)	or xdie "no recipients specified\n"
	unless $output || $embedded_to;
    unshift @recip, '-t' if $embedded_to;

    push @output, cont "To: ", join(", ", @to), "\n" if @to;
    push @output, cont "Cc: ", join(", ", @cc), "\n" if @cc;
    push @output, cont "Subject: $subject\n" if $subject ne '';

    push @output, $header if $header ne '';
    push @output, "MIME-Version: 1.0 ($Me $VERSION)\n"
	unless $subpart;

    # empty body
    if (@part == 0) {
	push @output, "\n";
    }

    # single part
    elsif (@part == 1) {
	push @output, $part[0];
    }

    # multipart
    else {
	push @part, $prelude;
	my $boundary = choose_boundary \@part;
	pop @part;

	push @output, cont "Content-Type: $multipart; boundary="
			    . token_quote($boundary) . "\n";
	push @output, "Content-Transfer-Encoding: $multipart_encoding\n"
	    unless $multipart_encoding eq '7bit';

	push @output, "\n$prelude" if $prelude ne '';

	for (@part) {
	    push @output, "\n--$boundary\n";
	    push @output, $_;
	}
	push @output, "\n--$boundary--\n";
    }

    # It's possible to wind up with a message with no trailing newline
    # (by explicitly giving an --encoding for a single part message
    # which lacks the trailing newline).  Add the newline in that case.
    push @output, "\n" unless $output[-1] =~ /\n\Z/;

    my ($fh, $cmd);
    if ($output) {
	$fh = *STDOUT;
	$cmd = 'stdout';
    }
    else {
	my $pid = open SENDMAIL, '|-';
	defined $pid or xdie "can't fork:";
	if (!$pid) {
    	    $ENV{PATH} = '/usr/local/bin:/bin:/usr/bin'
    	    	if !defined $ENV{PATH};
	    $ENV{PATH} .= ':/usr/sbin:/usr/lib';
	    exec qw(sendmail -oi), @recip
		or xdie "can't run sendmail:";
	}
	$fh = *SENDMAIL;
	$cmd = 'sendmail';
    }
    {
	local $SIG{PIPE} = 'IGNORE';
	for (@output) {
	    print $fh $_ or xdie "error writing to $cmd:";
	}
    }
    close_die $fh, $cmd;
}

sub main {
    init;
    process @ARGV;
    return 0;
}

$Exit = main || $Exit;
$Exit = 1 if $Exit && !($Exit % 256);
exit $Exit;

__END__

=head1 NAME

mime-construct - construct and optionally mail MIME messages

=head1 SYNOPSIS

B<mime-construct> I<switch>...

Sorry, it's hard to provide a meaningful synopsis.  See the examples.

=head1 DESCRIPTION

B<mime-construct> constructs and (by default) mails MIME messages.  It
is entirely driven from the command line, it is designed to be used by
other programs, or people who act like programs.

=head1 OPTIONS

=head2 Global Settings

=over 4

=item B<--debug>

Turn debugging on.

=item B<--help>

Show the usage message and die.

=item B<--output>

Don't mail the generated message, print it to stdout instead.  This
loses B<--bcc> info.

=item B<--subpart>

Generate a subpart which can be used in another MIME message, rather
than a top-level MIME message itself.  This turns on B<--output> and
changes some internal semantics a bit.  See the examples.

=item B<--version>

Print the version and exit successfully, if this is the only arg.
Otherwise, print the version and die.

=back

=head2 Main Header

These arguments add text to the top-level header of the message, or
control who it gets sent to.

=over 4

=item B<--bcc> I<address>

Add I<address> to the recipient list.  This doesn't actually add anything
to the header, of course.  If you're not actually mailing the message (if
you use B<--output> or B<--subpart>) B<--bcc> will have no effect.

=item B<--cc> I<address>

Add an address to the B<Cc:> list.

=item B<--embedded-to>

Send the message to the recipients already listed in the header, in
addition to those given with B<--to>, B<--cc>, and B<--bcc>.  This
makes sense if you use the B<--header> switch to add your own B<To:> or
B<Cc:>.  In this case you probably don't want to use B<--to> or B<--cc>
because they would create new headers rather than adding to the ones
already in the message.

This switch passes the B<-t> switch to sendmail (B<mime-construct>
doesn't try to parse the headers you provide), so it doesn't really do
anything if you're not mailing the message.

=item B<--header> I<str>

Add arbitrary text to the header.  The I<str> can be anything you like,
including multiple lines.  You can create invalid messages this way.
If you include a blank line in the I<str> you'll really screw up the
message.

=item B<--multipart> I<str>

This specifies the multipart content type and options.  The default is
C<multipart/mixed>.  Don't include a C<boundary> setting, that's supplied
by B<mime-construct>.

It's okay if you specify the B<--multipart> type but the message turns
out to be a single part, the type you supply will just be ignored.

=item B<--prelude> I<str>

This adds I<str> to the multipart prelude text.  If you specify
B<--prelude> multiple times the I<str>s will all be concatenated.

There isn't any default for this text.  It seems to me that nowadays
adding an explanation of MIME to the beginning of a message is like
explaining how to use a seat buckle to people who are riding in an
airplane.

It's okay if you specify the B<--prelude> but the message turns out to
be a single part, the prelude you supply will just be ignored.

=item B<--subject> I<str>

Specify the subject for the message.

=item B<--to> I<address>

Add an address to the B<To:> list.

=back

=head2 Per-part Header

These switches control the per-part headers.  If the message turns out
not to be multipart they actually add data to the top level header.

Each of these applies only to the next part output.  After each part is
output they are reset to their default values.  It doesn't make sense to
use them without a following part, so B<mime-construct> will sputter and
die if you try to do that.

=over 4

=item B<--attachment> I<name>

This adds a C<Content-Disposition: attachment> header with the given
I<name> as the value of the C<filename> attribute.  It's just a
convenience, since B<mime-construct> is often used to send files as
attachments.

Using B<--attachment> I<name> does not cause B<mime-construct> to read
any data from the file called I<name>!  It just uses that name in the
header.  The actual data which will go into this part of the message
comes from one of the regular part output switches (given below).

=item B<--encoding> I<type>

This specifies the type of encoding you want this part to use.  You
normally shouldn't use this switch, though.  If this switch isn't used
B<mime-construct> will choose an appropriate encoding.

The data you supply mustn't be encoded already, B<mime-construct> will
encode it according to the I<type> you specify here.  Valid encodings
are B<7bit>, B<8bit>, B<binary>, B<quoted-printable>, and B<base64>.
It's easy to generate an illegal MIME message by specifying the encoding
yourself.

=item B<--part-header> I<str>

Add arbitrary text to the per-part header.  The I<str> can be anything
you like, including multiple lines.  You can create invalid messages
this way.  If you include a blank line in the I<str> you'll really screw
up the message.

=item B<--type> I<type>

Specify the content type for this part.  If you don't specify a B<--type>
it defaults to C<text/plain>.  The I<type> you supply can contain not
only the type proper but also options.  The whole thing will just be
plopped onto the end of C<Content-Type:> and stuck into the header.

=back

=head2 Part Output

These switches add data to the body of the message.  You use one of
these for each for each part of a multipart message (or just one of them
if the message isn't to be multipart).

=over 4

=item B<--file> I<path>

=item B<--string> I<str>

Use the contents of the file I<path> or the literal string I<str> as the
body of this part.

Be sure to include the trailing newline on I<str> unless there really
isn't supposed to be one.  If you leave the trailing newline off the
part will have to be encoded in C<base64> (because C<quoted-printable>
has an artificial limitation which prevents it from being able to encode
such a data stream).

=item B<--subpart-file> I<path>

=item B<--subpart-string> I<str>

Use either the contents of I<path> or I<str> itself as the body of this
part, but treat it as a subpart.  This means that the data contains both
some headers and some text.  It also means that you can't use B<--type>
or B<--encoding> for this part.

Normally the I<path> or I<str> will have been generated by a different
invocation of B<mime-construct> which was given the B<--subpart> switch.

=back

Arguments to both B<--file> and B<--subpart-file> can have some magic.
If there is no file with the I<path> supplied a regular Perl open() is
done on it.  See L<"EXAMPLES">.

=head1 EXAMPLES

The examples assume than $nl contains a newline.  The other variables
used are I hope self-explanatory.

Send a simple message.

    mime-construct --to "$recip" --subject 'hi there' --string "$body"

Send a message which is read from stdin.

    fortune | mime-construct --to "$recip" --subject fortune --file -

Most people think of attachments as multipart messages, but they don't have
to be.  This generates a zip of all the files in the current directory and
sends them as an attachment but as a single part message.

    zip -q - * |
	mime-construct --to "$recip" --subject 'zipped directory' \
	    --attachment dir.zip --type application/zip --file -

This sends a zip file as an attachment in a multipart message, with some
text in the first part.

    mime-construct --to "$recip" --subject 'Mars or bust' \
    	--string "$explanatory_text" \
    	--type application/zip --attachment $zip --file $zip

You can use the full experessiveness of Perl's open() when constructing
file names.  Eg, you can run processes

    mime-construct --to "$recip" --subject "$subject" \
    	--string "Here are those two files you wanted.$nl" \
    	--type application/x-gzip --file 'gzip -c file1 |' \
    	--type application/x-gzip --file 'gzip -c file2 |'

or read from alternate file descriptors (C<E<lt>&=4> to read from file
descriptor 4) or whatever.  See the open() section of L<perlfunc> for
details.

Here's an example of using a separate invocation of B<mime-construct>
to create a subpart.  This creates a message which has two parts at the
top level.  The first part is some text, the second part is a digest.
The digest itself is a multipart message which contains a number of
messages/rfc822 parts.

    msg_args=
    for msg in $msg_list
    do
    	msg_args="$msg_args --type message/rfc822 --file $msg"
    done

    set fnord
    for recip in $recip_list
    do
    	set "$@" --bcc $recip
    done
    shift

    mime-construct --subpart --multipart multipart/digest $msg_args |
	mime-construct \
	    --header "To: Digest recipients:;$nl" \
	    --subject 'Foo digest' \
	    "$@" \
	    --file $introduction \
	    --subpart-file -

=head1 BUGS

The body of the message is always held in memory, so you can expect
problems if you work with bodies which are large compared to the amount
of memory you've got.

=head1 AUTHOR

Roderick Schertler <roderick@argon.org>

=cut