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

# minimail - cut+paste perl code to parse/create mbox files and mail messages
#
# Copyright (C) 2005-2007 raf <raf@raf.org>
#
# 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.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
# or visit http://www.gnu.org/copyleft/gpl.html
#
# 20070803 raf@raf.org

=head1 NAME

I<minimail> - cut+paste perl code to parse/create mbox files and mail messages

=head1 DESCRIPTION

I<minimail> is a collection of functions that parse and produce mailbox
files and individual mail messages. It is not a module (although
uncommenting one line and calling it C<minimail.pm> would turn itinto a
module). It is intended to be compact enough to cut and paste directly into
perl scripts that don't want to require non-standard perl modules. In other
words, it is intended to be yet another alternative to I<MIME-tools>.
I<MIME-tools> does things that this code doesn't (such as uuencode
decoding). And I<minimail> does things that I<MIME-tools> doesn't such as
reading and writing mailbox files correctly (repairing incorrectly formatted
ones along the way), automatically encoding and decoding mail headers and
MIME header parameters, and transparently unravelling C<winmail.dat>
attachments (aka I<MS-TNEF>). I<minimail> is much smaller (about 3% of the
size of I<MIME-tools> and the other modules it requires and about 20% of the
size of I<MIME-Lite>) and so takes much less time during program startup.

=head1 FUNCTIONS

=over 4

=item formail(sub { <> }, sub { $mail = shift })

Parses a mailbox or a mail message. Calls the first argument to retrieve
input lines and calls the second function with every mail message found.
Terminates when the first argument returns undef or when the second function
returns false. Quoted C<From_> lines are unquoted.

=item mail2str($mail)

Returns a string version of a mail message. If the mail message includes a
mailbox header, lines in the body starting with C<From_> are quoted and the
string result will definitely be terminated with a blank line. This means
that mailbox files with blank lines missing between mail messages and with
unquoted C<From_> lines will be automatically repaired with the code below
(Incidentally, malformed nested multipart body parts are also repaired).

 formail(sub { <> }, sub { print mail2str(shift) });

=item mail2multipart($mail)

Converts a singlepart mail message into a multipart mail message with a
single body part (i.e. the body of the original mail message). Returns the
mail message. Does nothing to mail messages that are already multipart mail
messages.

=item mail2singlepart($mail)

Converts a multipart mail message with a single body part into a singlepart
mail message whose body is the original body part. Returns the mail message.
Does nothing to mail messages that are already singlepart mail messages or
multipart mail messages with multiple parts. Acts recursively.

=item mail2mbox($mail)

Converts a mail message into an mailbox item. Does nothing to mail messages
that are already mailbox items. This affects the result of I<mail2str()>.

=item insert_header($mail, $header[, $language[, $charset]])

Inserts a new mail header before any existing mail headers. If the header
contains non-ascii characters, it will be encoded in accordance with
RFC2047. If the I<$language> and I<$charset> parameters are not supplied,
they default to C<en> and C<iso-8859-1>, respectively.

=item append_header($mail, $header[, $language[, $charset]])

Appends a new mail header after any existing mail headers.

=item replace_header($mail, $header[, $language[, $charset]])

Replaces all instances of a mail header with a new mail header.

=item delete_header($mail, $header, $recurse)

Deletes all headers that match the I<$header> pattern. If the I<$recurse>
parameter is provided and non-zero, matching headers in internal body parts
will also be deleted.

=item insert_part($mail, $part, $index)

Inserts the given body part at the given index. The I<$part> parameter must
have been produced by I<formail()> or I<newmail()>. The I<$mail> parameter
must already be a multipart mail message.

=item append_part($mail, $part)

Appends the given body part.

=item replace_part($mail, $part, $index)

Replaces the body part at the given index with the given body part.

=item delete_part($mail, $index)

Deletes the body part at the given index.

=item header($mail, $header)

Returns a list of values of headers with the given name. RFC2822 comments
are removed. If any of the values contain RFC2047 encoded words (i.e.
C<=?charset?[qb]?...?=>), and the charset is C<us-ascii> or C<iso-8859-*>,
they are decoded. They are also unfolded. If this is not what you want, use
$mail->{header} or $mail->{headers} directly (or change the code).

=item headers($mail)

Returns a list of all complete headers with decoding and unfolding performed
as with I<header()>.

=item header_names($mail)

Returns a list of the names of headers present in the given mail message.

=item param($mail, $header, $param)

Returns the value of the given parameter of the given MIME header of the
given mail message. I<header()> is used for RFC2047 decoding. If the
parameter has been split or encoded in accordance with RFC2231 (i.e.
C<param1*0="a" param1*1="b" param2*="charset'lang'%63">), it is decoded (if
C<us-ascii> or C<iso-8859-*>) and reassembled.

=item mimetype($mail, $parent)

Returns the declared or default mimetype of the given mail message or body
part. Returns C<octet/application> when the encoding is invalid.

=item encoding($mail)

Returns the declared or implied encoding of the given mail message or body
part.

=item filename($part)

Returns the RFC2183 filename of the given body part. Uses I<param()> to
perform any decoding that might be necessary. Also removes any directory
component of the filename and replaces any unfriendly characters with dash
characters.

=item body($mail)

Returns the decoded body of the given mail message or body part. Must not be
called on a multipart mail message or a mail message whose mimetype is
C<message/rfc822>.

=item message($mail)

Returns the message inside the given mail message whose mimetype is
C<message/rfc822>. Must not be called on a multipart message or a mail
message whose mimetype is not C<message/rfc822>.

=item parts($mail[, $part])

When no I<$part> parameter is given, returns a reference to an array of body
parts in the given multipart message. When the I<$parts> parameter is given,
it is a reference to an array of body parts, and it will replace the
existing body parts. Must not be called on a singlepart mail message.

=item newparam($name, $value[, $language[, $charset]]])

Creates a MIME header parameter, possibly split and encoded in accordance
with RFC2231. Returns a string that looks like C<"; name=value"> which can
be used as part of the I<$header> argument in functions like
I<append_header()> and as part of any header value in the function
I<newmail()>. If the value contains non-ascii characters, and the
I<$language> and I<$charset> parameters are not supplied, they default to
C<en> and C<iso-8859-1>, respectively.

=item newmail(...)

Creates a new mail message based on the given arguments (which take the form
of a hash). It is not necessary to supply all information. Anything that
needs to be added will be added automatically. The important parameters are:

 [A-Z]*      - Arbitrary mail headers: e.g. From To Subject
 type        - Content-Type: e.g. image/png
 charset     - Content-Type's charset parameter: e.g. iso-8859-1
 encoding    - Content-Transfer-Encoding: e.g. base64
 filename    - Content-Disposition's filename parameter
 body        - body of the message (don't use with parts or message)
 parts       - array-ref of parts (don't use with body or message)
 message     - body of message/rfc822 message (don't use with body or parts)
 mbox        - Mbox From_ header

Supplying I<body> implies C<text/plain>. Supplying I<parts> implies
C<multipart/mixed>. Supplying I<message> implies C<message/rfc822>. Default
I<disposition> is C<inline> for C<text/*> and C<message/rfc822> or
C<attachment> for all other types. The default I<charset> is C<iso-8859-1>
when I<body> contains non-ascii characters, C<us-ascii> otherwise. Default
I<encoding> is determined from the type and nature of the mail message and
its data. You shouldn't have to supply I<encoding> unless you want to create
messages with C<8bit> encoding. If the mail message really is a mail
message, and not just a body part, C<Date>, C<MIME-Version> and
C<Message-ID> headers are automatically included if they have not been
supplied by the caller.

Less important parameters are:

 disposition - Content-Disposition: i.e. inline or attachment
 created     - Content-Disposition's creation-date parameter
 modified    - Content-Disposition's modification-date parameter
 read        - Content-Disposition's read-date parameter
 size        - Content-Disposition's size parameter
 description - Content-Description
 language    - Content-Language
 duration    - Content-Duration
 location    - Content-Location
 base        - Content-Base
 features    - Content-Features
 alternative - Content-Alternative
 id          - Content-ID
 md5         - Content-MD5

Note: If you supply C<filename> but not C<body> (or C<message> or C<parts>),
and the filename refers to a readable file, then the following parameters
will be determined automatically: C<body>, C<modified>, C<read>, C<size>.

The rest of the less important parameters are just shortcuts for standard
MIME headers. There is no support beyond that for any of them.

=back

=head1 STRUCTURE

A mail message (or body part) is a hash containing some of the following
entries:

 mbox          - mailbox From_ header
 warn          - parser errors in the form: X-Warning: ...
 headers       - arrayref of mail headers in order of appearance
 header        - hashref by name of arrayrefs of mail headers
 body          - text of singlepart mail message
 mime_type     - mimetype of the mail message or body part
 mime_parts    - arrayref of mail messages (body parts)
 mime_message  - message of a message/rfc822 mail message
 mime_boundary - boundary for a multipart mail message
 mime_preamble - any text before the first multipart boundary
 mime_epilogue - any text after the last multipart boundary
 mime_prev_boundary - saved boundary of message after mail2singlepart
 mime_prev_preamble - saved preamble of message after mail2singlepart
 mime_prev_epilogue - saved epilogue of message after mail2singlepart

Note that I<body>, I<mime_parts> and I<mime_message> are mutually exclusive
and that I<mime_type> only exists when I<mime_parts> or I<mime_message> exist.

=head1 EXAMPLES

Parsing example: Repair mailbox files

 formail(sub { <> }, sub { print mail2str(shift) });

Building example: A mail message with attachments

 print mail2str(newmail(
  To => 'you@there.com', From => 'me@here.com', Subject => 'test',
  parts => [
  	newmail(body => "hi\n"),
  	newmail(body => $png, type => 'image/png', filename => 'hi.png'),
	newmail(message => newmail(qw(To to@you From from@me body hi")))
 ]));

=head1 CAVEAT

The I<header()> and I<headers()> functions automatically decode rfc2047
encoded headers when the character set us C<us-ascii> or any of the
C<iso-8859-*> character sets. This is an attempt to satisfy the following
requirement in rfc2047:

 The program must be able to display the unencoded text if the
 character set is "US-ASCII".  For the ISO-8859-* character sets,
 the mail reading program must at least be able to display the
 characters which are also in the ASCII set.

The problem is that rather than discarding C<iso-8859-*> characters that are
not also C<us-ascii>, I<minimail> decodes and "displays" them. This is
arguably more useful but knowledge of the character set is lost and the
characters will be interpreted as being in your character set. No doubt,
this could be the wrong thing if your character set is very different from
that used by the originators of the mail messages being parsed.

If this is likely to cause you problems, don't use I<header()> or
I<headers()>. Use C<$mail-E<gt>{headers}> instead which is a reference to an
array of raw encoded headers. Or delete or transform any high bit characters
in the results of these functions. Or change the code so that it doesn't
automatically decode character sets that you don't want it to.

=head1 SEE ALSO

rfc2822, rfc2045, rfc2046, rfc2047, rfc2231, rfc2183 (also rfc3282, rfc3066,
rfc2424, rfc2557, rfc2110, rfc3297, rfc2912, rfc2533, rfc1864, rfc2387,
rfc2912, rfc2533, rfc2387, rfc2076, rfc4012).

The mailbox format used is the mboxrd format described in
C<http://www.qmail.org/man/man5/mbox.html>.

=head1 AUTHOR

20070803 raf <raf@raf.org>

=cut

# Uncomment the next line to convert minimail into a Perl module.
# package minimail; use Exporter; use vars qw($VERSION @ISA @EXPORT); $VERSION = 1.0; @ISA = 'Exporter'; @EXPORT = qw(formail mail2str mail2multipart mail2singlepart mail2mbox insert_header append_header replace_header delete_header insert_part append_part replace_part delete_part header headers header_names param mimetype encoding filename body message parts newparam newmail);

sub formail # rfc2822 + mboxrd format (see http://www.qmail.org/man/man5/mbox.html)
{
	sub mime # rfc2045, rfc2046
	{
		my ($mail, $parent) = @_;
		return $mail unless exists $mail->{header} && exists $mail->{header}->{'content-type'} || defined $parent && exists $parent->{mime_type} && $parent->{mime_type} =~ /^multipart\/digest$/i;
		my ($content_type) = (exists $mail->{header} && exists $mail->{header}->{'content-type'}) ? @{$mail->{header}->{'content-type'}} : "Content-Type: message/rfc822\n";
		my ($type) = $content_type =~ /^content-type:\s*([\w\/.-]+)/i;
		my $boundary = param($mail, 'content-type', 'boundary') if $type =~ /^multipart\//i;
		return $mail unless defined $type && ($type =~ /^multipart\//i && $boundary || $type =~ /^message\/rfc822$/i);
		($mail->{mime_boundary}) = $boundary =~ /^(.*\S)/ if $boundary;
		$mail->{mime_type} = $type;
		$mail->{mime_message} = mimepart(delete $mail->{body} || '', $mail), return $mail if $type =~ /^message\/(?:rfc822|external-body)$/i;
		return tnef2mime(mimeparts($mail, $parent));
	}

	sub mimeparts
	{
		my ($mail, $parent) = @_;
		my $state = 'preamble';
		my $text = '';

		for (split /(?<=\n)/, delete $mail->{body} || '')
		{
			if (/^--\Q$mail->{mime_boundary}\E(--)?/)
			{
				if ($state eq 'preamble')
				{
					$state = 'part';
					$mail->{mime_preamble} = $text if length $text;
				}
				elsif ($state eq 'part')
				{
					$state = 'epilogue' if defined $1 && $1 eq '--';
					push @{$mail->{mime_parts}}, mimepart($text, $mail);
				}

				$text = '', next;
			}

			$text .= $_;
		}

		push @{$mail->{mime_parts}}, mimepart($text, $mail) if $state eq 'part' && length $text;
		$mail->{mime_epilogue} = $text if $state eq 'epilogue' && length $text;
		return $mail;
	}

	sub mimepart
	{
		my ($mail, $parent) = @_;
		my @lines = split /(?<=\n)/, $mail;
		formail(sub { shift @lines }, sub { $mail = shift }, $parent);
		return $mail;
	}

	my ($rd, $act, $parent) = @_;
	my $state = 'header';
	my $mail; my $last;

	while (defined($_ = $rd->()))
	{
		s/\r(?=\n)//g; #, tr/\r/\n/;

		if (!defined $parent && /^From (?:\S[^\n]+)?\s+[a-zA-Z]+\s+[a-zA-Z]+\s+\d{1,2}\s+\d{2}:\d{2}:\d{2}\s+(?:[A-Z]+\s+)?\d{4}/) # mbox header
		{
			$mail->{body} =~ s/\n\n\z/\n/ if $mail && exists $mail->{mbox} && exists $mail->{body};
			my $mbox = $_; $act->(mime($mail, $parent)) or return if $mail;
			$mail = { mbox => $mbox }, $state = 'header', undef $last, next;
		}

		if ($state eq 'header')
		{
			if (/^([\w-]+):/) # mail header
			{
				push @{$mail->{headers}}, $_;
				push @{$mail->{header}->{$last = lc $1}}, $_;
			}
			elsif (/^$/) # blank line after mail headers
			{
				$mail->{body} = '', $state = 'body';
			}
			else # mail header continuation or error
			{
				#$mail->{warn} .= "X-Warning: invalid header: $_" unless /^[ \t]+/ && defined $last;
				${$mail->{headers}}[$#{$mail->{headers}}] .= $_ if defined $last;
				${$mail->{header}->{$last}}[$#{$mail->{header}->{$last}}] .= $_ if defined $last;
			}
		}
		elsif ($state eq 'body')
		{
			s/^>(>*From )/$1/ if exists $mail->{mbox};
			$mail->{body} .= $_;
		}
	}

	$mail->{body} =~ s/\n\n\z/\n/ if $mail && exists $mail->{mbox} && exists $mail->{body};
	$act->(mime($mail, $parent)) if $mail;
}

sub mail2str
{
	my $mail = shift;
	my $head = '';
	$head .= $mail->{mbox} if exists $mail->{mbox};
	$head .= $mail->{warn} if exists $mail->{warn};
	$head .= join '', @{$mail->{headers}} if exists $mail->{headers};
	my $body = '';
	$body .= $mail->{body} if exists $mail->{body};
	$body .= "$mail->{mime_preamble}" if exists $mail->{mime_preamble};
	$body .= "--$mail->{mime_boundary}\n" if exists $mail->{mime_boundary} && !exists $mail->{mime_parts};
	$body .= join("", map { "--$mail->{mime_boundary}\n" . mail2str($_) } @{$mail->{mime_parts}}) if exists $mail->{mime_parts};
	$body .= "--$mail->{mime_boundary}--\n" if exists $mail->{mime_boundary};
	$body .= "$mail->{mime_epilogue}" if exists $mail->{mime_epilogue};
	$body .= mail2str($mail->{mime_message}) if exists $mail->{mime_message};
	$body =~ s/^(>*From )/>$1/mg, $body =~ s/([^\n])\n?\z/$1\n\n/ if exists $mail->{mbox};
	return $head . "\n" . $body;
}

my $bchar = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ'()+_,-.\/:=?";
sub mail2multipart
{
	my $m = shift;
	return $m if exists $m->{mime_type} && $m->{mime_type} =~ /^multipart\//i;
	my $p = {};
	append_header($p, $_) for grep { /^content-/i } @{$m->{headers}};
	$p->{body} = delete $m->{body} if exists $m->{body};
	$p->{mime_message} = delete $m->{mime_message} if exists $m->{mime_message};
	$p->{mime_type} = $m->{mime_type} if exists $m->{mime_type};
	$m->{mime_type} = 'multipart/mixed';
	$m->{mime_boundary} = exists $m->{mime_prev_boundary} ? delete $m->{mime_prev_boundary} : join '', map { substr $bchar, int(rand(length $bchar)), 1 } 0..30;
	$m->{mime_preamble} = delete $m->{mime_prev_preamble} if exists $m->{mime_prev_preamble};
	$m->{mime_epilogue} = delete $m->{mime_prev_epilogue} if exists $m->{mime_prev_epilogue};
	delete_header($m, qr/content-[^:]*/i);
	append_header($m, 'MIME-Version: 1.0') unless exists $m->{header} && exists $m->{header}->{'mime-version'};
	append_header($m, "Content-Type: $m->{mime_type}; boundary=\"$m->{mime_boundary}\"");
	$m->{mime_parts} = [$p];
	return $m;
}

sub mail2singlepart
{
	my $m = shift;
	$m->{mime_message} = mail2singlepart($m->{mime_message}), return $m if exists $m->{mime_type} && $m->{mime_type} =~ /^message\//i;
	return $m unless exists $m->{mime_type} && $m->{mime_type} =~ /^multipart\//i && @{$m->{mime_parts}} <= 1;
	my $p = shift @{$m->{mime_parts}};
	$m->{mime_prev_boundary} = delete $m->{mime_boundary} if exists $m->{mime_boundary};
	$m->{mime_prev_preamble} = delete $m->{mime_preamble} if exists $m->{mime_preamble};
	$m->{mime_prev_epilogue} = delete $m->{mime_epilogue} if exists $m->{mime_epilogue};
	$m->{body} = $p->{body} if exists $p->{body};
	$m->{mime_message} = $p->{mime_message} if exists $p->{mime_message};
	delete $m->{mime_type}; $m->{mime_type} = $p->{mime_type} if exists $p->{mime_type};
	delete $m->{mime_parts}; $m->{mime_parts} = $p->{mime_parts} if exists $p->{mime_parts};
	$m->{mime_boundary} = $p->{mime_boundary} if exists $p->{mime_boundary};
	$m->{mime_preamble} = $p->{mime_preamble} if exists $p->{mime_preamble};
	$m->{mime_epilogue} = $p->{mime_epilogue} if exists $p->{mime_epilogue};
	my $explicit = 0;
	delete_header($m, qr/content-[^:]*/i);
	append_header($m, $_), ++$explicit for grep { /^content-/i } @{$p->{headers}};
	delete_header($m, 'mime-version') unless $explicit;
	return mail2singlepart($m);
}

sub mail2mbox
{
	my $m = shift;
	return $m if exists $m->{mbox};
	my ($f) = header($m, 'sender');
	($f) = header($m, 'from') unless defined $f;
	$f =~ s/"(?:\\[^\r\n]|[^\\"])*"//g, $f =~ s/\s*;.*//, $f =~s/^[^:]+:\s*//, $f =~ s/\s*,.*$//, $f =~ s/^[^<]*<\s*//, $f =~ s/\s*>.*$// if defined $f;
	$f = 'unknown' unless defined $f;
	use POSIX; $m->{mbox} = "From $f  " . ctime(time());
	return $m;
}

sub insert_header
{
	my ($m, $h, $l, $c) = @_;
	$h = header_format($h, $l, $c);
	my ($n) = $h =~ /^([^:]+):/;
	unshift @{$m->{headers}}, $h;
	unshift @{$m->{header}->{lc $n}}, $h;
}

sub append_header
{
	my ($m, $h, $l, $c) = @_;
	$h = header_format($h, $l, $c);
	my ($n) = $h =~ /^([^:]+):/;
	push @{$m->{headers}}, $h;
	push @{$m->{header}->{lc $n}}, $h;
}

sub replace_header
{
	my ($m, $h, $l, $c) = @_;
	$h = header_format($h, $l, $c);
	my ($n) = $h =~ /^([^:]+):/;
	my $seen = 0; @{$m->{headers}} = grep { defined $_ } map { /^\Q$n\E:/i ? $seen ? undef : do { ++$seen; $h } : $_ } @{$m->{headers}};
	splice @{$m->{header}->{lc $n}};
	push @{$m->{header}->{lc $n}}, $h;
}

sub delete_header
{
	my ($m, $h, $r) = @_;
	return undef unless exists $m->{header};
	@{$m->{headers}} = grep { !/^$h:/i } @{$m->{headers}};
	delete $m->{header}->{$_} for grep { /^$h$/i } keys %{$m->{header}};
	if ($r && exists $m->{mime_parts}) { delete_header($_, $h, $r) for @{$m->{mime_parts}} }
	if ($r && exists $m->{mime_message}) { delete_header($m->{mime_message}, $h, $r) }
}

sub insert_part
{
	my ($m, $p, $i) = @_;
	splice @{$m->{mime_parts}}, $i || 0, 0, $p;
}

sub append_part
{
	my ($m, $p) = @_;
	push @{$m->{mime_parts}}, $p;
}

sub replace_part
{
	my ($m, $p, $i) = @_;
	splice @{$m->{mime_parts}}, $i, 1, $p;
}

sub delete_part
{
	my ($m, $i) = @_;
	splice @{$m->{mime_parts}}, $i, 1;
}

sub header
{
	my ($m, $h) = @_;
	return () unless exists $m->{header} && exists $m->{header}->{lc $h};
	return map { s/\n\s+/ /g; $_ = header_display($_); /^$h:\s*(.*)\s*$/i; $1 } @{$m->{header}->{lc $h}};
}

sub headers
{
	my $m = shift;
	return () unless exists $m->{headers};
	return map { s/\n\s+/ /g; $_ = header_display($_); /^([\w-]+:.*)\s*$/; $1 } @{$m->{headers}};
}

sub header_names
{
	my $m = shift;
	return () unless exists $m->{header};
	return keys %{$m->{header}};
}

my $encword = qr/=\?(us-ascii|iso-8859-\d)(?:\*\w+)?\?(q|b)\?([^? ]+)\?=/i; # encoded words to display (should really only decode ascii)
sub header_display # rfc2047, rfc2231
{
	return join '',
		map { tr/ \t/ /s; $_ } # finally, squeeze multiple whitespace
		map { tr/\x00-\x08\x0b-\x1f\x7f//d; $_ } # strip control characters
		map { s/$encword/lc $2 eq 'q' ? join ' ', split '_', decode_quoted_printable($3), -1 : decode_base64($3)/ieg; $_ } # decode encoded words
		map { s/($encword)\s+($encword)/$1$5/g while /$encword\s+$encword/; $_ } # strip space between encoded words that we're about to decode
		map { s/\((?:\\[^\r\n]|[^\\()])*\)//g unless /^".*"$/; $_ } # strip (comments) outside "quoted strings"
		split /("(?:\\[^\r\n]|[^\\"])*")/, shift; # split on "quoted strings"
}

sub header_format # rfc2822, rfc2047
{
	my ($h, $l, $c) = @_;
	$h =~ s/^\s+//, $h =~ s/\s+$//, $h =~ tr/ \t\n\r/ /s;
	$h = join ' ', map { /^".*"$/ ? $_ : !tr/\x80-\xff// ? $_ : tr/a-zA-Z0-9!*\/+-//c > length >> 1 ? join(' ', map { '=?' . ($c || 'iso-8859-1') . ($l ? "*$l" : '') . '?b?' . substr(encode_base64($_), 0, -1) . '?=' } (split /\n/, (s/([^\r\n]{38})/$1\n/g, $_))) : join(' ', map { '=?' . ($c || 'iso-8859-1') . ($l ? "*$l" : '') . '?q?' . substr(encode_quoted_printable($_), 0, -2) . '?=' } (split /\n/, (s/([^\r\n]{17})/$1\n/g, $_))) } map { /^[^\s"]*".*"[^\s"]*$/ ? $_ : split / / } split /(\S*"(?:\\[^\r\n]|[^\\"])*"\S*)/, $h;
	my ($f, $p, $lf) = ('', 0); $lf = length $f, $f .= ($lf && $lf + ($lf ? 1 : 0) + length($_) - $p > 78) ? ($p = $lf, "\n") : '', $f .= $f ? ' ' : '', $f .= $_ for map { /^\S*".*"\S*$/ ? $_ : grep { length } split / / } split /(\S*"(?:\\[^\r\n]|[^\\"\r\n])*"\S*)/, $h; # fold
	return $f . "\n";
}

sub param # rfc2231, rfc2045
{
	my ($m, $h, $p) = @_;
	my @p; my $decode = 0;

	for (header($m, $h))
	{
		while (/(\b\Q$p\E(?:\*|\*\d\*?)?)=("(?:\\[^\n]|[^"\n])*"|[^\x00-\x20()<>@,;:\\"\/\[\]?=]+)/ig)
		{
			my ($n, $v) = ($1, $2);
			$v =~ s/^"//, $v =~ s/"$//, $v =~ s/\\(.)/$1/g if $v =~ /^".*"$/;
			$v =~ s/^(?:us-ascii|iso-8859-\d)'\w+'//i and $decode = 1;
			$v =~ s/%([\da-fA-f]{2})/chr hex $1/eg if $decode && substr($n, -1) eq '*';
			push @p, [lc $n, $v];
		}
	}

	return join '', map { $_->[1] } sort { my ($ad) = $a->[0] =~ /(\d+)/; my ($bd) = $b->[0] =~ /(\d+)/; $ad <=> $bd } @p;
}

sub mimetype # rfc2045, rfc2046
{
	my ($m, $p) = @_;
	my ($e) = header($m, 'content-transfer-encoding');
	return 'application/octet-stream' if defined $e && $e !~ /^(?:[78]bit|binary|quoted-printable|base64)$/i;
	my ($type) = header($m, 'content-type');
	return lc $1 if defined $type && $type =~ /^((?:text|image|audio|video|application|message|multipart)\/[^\s;]+)/i;
	return 'message/rfc822' if !defined $type && defined $p && exists $p->{mime_type} && $p->{mime_type} =~ /^multipart\/digest/i;
	return 'text/plain';
}

sub encoding # rfc2045
{
	my $m = shift;
	my ($e) = header($m, 'content-transfer-encoding');
	return (defined $e && $e =~ /^([78]bit|binary|quoted-printable|base64)$/i) ? lc $1 : (exists $m->{body} && $m->{body} =~ tr/\x80-\xff//) ? '8bit' : '7bit';
}

my $unique;
sub filename # rfc2183, rfc2045?
{
	my $p = shift;
	my $fn = param($p, 'content-disposition', 'filename') || param($p, 'content-type', 'name') || 'attachment' . ++$unique;
	$fn =~ s/^.*[\\\/]//, $fn =~ tr/\x00-\x1f !"#\$%&'()*\/:;<=>?@[\\]^`{|}~\x7f/_/s;
	return $fn;
}

sub body
{
	my $m = shift;
	return exists $m->{body} ? decode($m->{body}, encoding($m)) : undef;
}

sub message
{
	my $m = shift;
	return exists $m->{mime_message} ? $m->{mime_message} : undef;
}

sub parts
{
	my ($m, $p) = @_;
	return [@{$m->{mime_parts}}] unless defined $p;
	$m->{mime_parts} = [@$p];
}

sub newparam # rfc2231, rfc2045
{
	my ($n, $v, $l, $c) = (@_, '', '');
	my $high = $v =~ tr/\x80-\xff//;
	my $ctrl = $v =~ tr/\x00-\x06\x0e-\x1f\x7f//;
	my $enc = $high || $ctrl ? '*' : '';
	$c = ('high' ? 'iso-8859-1' : 'us-ascii') if $enc && !$c;
	$l = 'en' if $c && !$l;
	$v = "$c'$l'$v" if $enc;
	my @p; push @p, $_ while $_ = substr $v, 0, 40, '';
	s/([\x00-\x20\x7f-\xff])/sprintf '%%%02X', ord $1/eg for grep { tr/\x00-\x06\x0e-\x1f\x7f-\xff// } @p;
	s/"/\\"/g, s/^/"/g, s/$/"/g for grep { tr/\x00-\x06\x0e-\x1f\x7f ()<>@,;:\\"\/[]?=// } @p;
	return "; $n$enc=$p[0]" if @p == 1;
	return join '', map { "; $n*$_$enc=$p[$_]" } 0..$#p;
}

sub newmail # rfc2822, rfc2045, rfc2046, rfc2183 (also rfc3282, rfc3066, rfc2424, rfc2557, rfc2110, rfc3297, rfc2912, rfc2533, rfc1864)
{
	my @a = @_; my %a = @_; my $m = {};
	sub rfc822date { use POSIX; return strftime '%a, %d %b %Y %H:%M:%S +0000', gmtime shift; }
	my $type = $a{type} || (exists $a{parts} ? 'multipart/mixed' : exists $a{message} ? 'message/rfc822' : 'text/plain');
	my $multi = $type =~ /^multipart\//i;
	my $msg = $type =~ /^message\/rfc822$/i;
	($a{body}, $a{modified}, $a{read}, $a{size}) = (do { local $/; my $b = <F>; close F; $b }, exists $a{modified} ? $a{modified} : rfc822date((stat _)[9]), exists $a{read} ? $a{read} : rfc822date((stat _)[8]), (stat _)[7]) if exists $a{filename} && !exists $a{body} && !exists $a{message} && !exists $a{parts} && -r $a{filename} && stat($a{filename}) && open F, $a{filename};
	($a{filename}) = $a{filename} =~ /([^\\\/]+)$/ if $a{filename};
	my $bound = $multi ? join '', map { substr $bchar, int(rand(length $bchar)), 1 } 0..30 : '';
	my $disp = $a{disposition} || ($type =~ /^(?:text\/|message\/rfc822)/i ? 'inline' : 'attachment');
	my $char = $a{charset} || ($a{body} && $a{body} =~ tr/\x80-\xff// ? 'iso-8859-1' : 'us-ascii');
	my $enc = $a{encoding} || ($multi || $msg ? '7bit' : $a{body} ? choose_encoding($a{body}) : '7bit');
	append_header($m, $a[$_] . ': ' . $a[$_ + 1]) for grep { $_ % 2 == 0 && $a[$_] =~ /^[A-Z]/ } 0..$#a;
	append_header($m, 'Date: ' . rfc822date(time)) if grep { /^(?:date|from|sender|reply-to)$/i } keys %a and !grep { /^date$/i } keys %a;
	append_header($m, 'MIME-Version: 1.0') if grep { /^(?:date|from|sender|reply-to)$/i } keys %a and !grep { /^mime-version$/ } keys %a;
	use Sys::Hostname; append_header($m, "Message-ID: <@{[time]}.$$.@{[++$unique]}\@@{[hostname]}>") if grep { /^(?:date|from|sender|reply-to)$/i } keys %a and !grep { /^message-id$/i } keys %a;
	append_header($m, "Content-Type: $type" . ($bound ? newparam('boundary', $bound) : '') . ($char =~ /^us-ascii$/i ? '' : newparam('charset', $char))) unless $type =~ /^text\/plain$/i && $char =~ /^us-ascii$/i;
	append_header($m, "Content-Transfer-Encoding: $enc") unless $enc =~ /^7bit$/i;
	append_header($m, "Content-Disposition: $disp" . ($a{filename} ? newparam('filename', $a{filename}) : '') . ($a{size} ? newparam('size', $a{size}) : '') . ($a{created} ? newparam('creation-date', $a{created}) : '') . ($a{modified} ? newparam('modification-date', $a{modified}) : '') . ($a{read} ? newparam('read-date', $a{read}) : '')) if $a{filename} || $a{size} || $a{created} || $a{modified} || $a{read};
	append_header($m, "Content-@{[ucfirst $_]}: $a{$_}") for grep { $a{$_} } qw(description language duration location base features alternative);
	append_header($m, "Content-@{[uc $_]}: $a{$_}") for grep { $a{$_} } qw(id md5);
	($m->{mime_type}, $m->{mime_boundary}, $m->{mime_parts}) = ($type =~ /^\s*([\w\/.-]+)/, $bound, $a{parts} || []) if $multi;
	($m->{mime_type}, $m->{mime_message}) = ($type =~ /^\s*([\w\/.-]+)/, $a{message} || {}) if $msg;
	$m->{body} = encode($a{body} || '', $enc) unless $multi || $msg;
	$m->{mbox} = $a{mbox} if exists $a{mbox} && defined $a{mbox} && length $a{mbox};
	return $m;
}

sub decode
{
	my ($d, $e) = @_;
	return $e =~ /^base64$/i ? decode_base64($d) : $e =~ /^quoted-printable$/i ? decode_quoted_printable($d) : substr($d, 0, -1);
}

sub encode
{
	my ($d, $e) = @_;
	return $e =~ /^base64$/i ? encode_base64($d) : $e =~ /^quoted-printable$/i ? encode_quoted_printable($d) : $d . "\n";
}

sub choose_encoding # rfc2822, rfc2045
{
	my $len = length $_[0];
	my $high = $_[0] =~ tr/\x80-\xff//;
	my $ctrl = $_[0] =~ tr/\x00-\x06\x0e-\x1f\x7f//;
	my ($maxlen, $pos, $next) = (0, 0, 0);

	for (; ($next = index($_[0], "\n", $pos)) != -1; $pos = $next + 1)
	{
		$maxlen = $next - $pos if $next - $pos > $maxlen;
	}

	$maxlen = $len - $pos if $len - $pos > $maxlen;
	return $ctrl ? 'base64' : $high ? $len > 1024 && $high > $len * 0.167 ? 'base64' : 'quoted-printable' : $maxlen > 998 ? 'quoted-printable' : '7bit';
}

sub encode_base64 # MIME::Base64 (Gisle Aas)
{
	pos $_[0] = 0; # Note: Text must be in canonical form (i.e. with "\r\n")
	my $padlen = (3 - length($_[0]) % 3) % 3;
	my $encoded = join '', map { pack('u', $_) =~ /^.(\S*)/ } $_[0] =~ /(.{1,45})/gs;
	$encoded =~ tr{` -_}{AA-Za-z0-9+/};
	$encoded =~ s/.{$padlen}$/'=' x $padlen/e if $padlen;
	$encoded =~ s/(.{1,76})/$1\n/g;
	return $encoded;
}

sub decode_base64 # MIME::Base64 (Gisle Aas)
{
	my $data = shift;
	$data =~ tr{A-Za-z0-9+=/}{}cd;
	$data =~ s/=+$//;
	$data =~ tr{A-Za-z0-9+/}{ -_};
	return join '', map { unpack("u", chr(32 + length($_) * 3 / 4) . $_) } $data =~ /(.{1,60})/gs;
}

sub encode_quoted_printable
{
	my $quoted = shift;
	my $binary = ($quoted =~ tr/\x00-\x06\x0e-\x1f\x7f//) ? '' : '\r\n';
	$quoted =~ s/([^!-<>-~ \t$binary])/sprintf '=%02X', ord $1/eg;
	$quoted =~ s/((?:[^\r\n]{73,75})(?=[=])|(?:[^\r\n]{75}(?=[ \t]))|(?:[^\r\n]{75})(?=[^\r\n]{2})|(?:[^\r\n]{75})(?=[^\r\n]$))/$1=\n/g;
	$quoted =~ s/([ \t])$/sprintf '=%02X', ord $1/emg;
	$quoted .= "=\n" unless $quoted =~ /\n$/;
	return $quoted;
}

sub decode_quoted_printable
{
	my $quoted = shift;
	$quoted =~ tr/\x00-\x08\x0b-\x0c\x0e-\x19\x7f-\xff//d;
	$quoted =~ s/=\n//g;
	$quoted =~ s/=([0-9A-Fa-f]{2})/chr hex $1/eg;
	return $quoted;
}

my %mimetype =
(
	txt => 'text/plain', csv => 'text/plain', htm => 'text/html', html => 'text/html', vcf => 'text/x-vcard',
	gif => 'image/gif', jpg => 'image/jpeg', jpeg => 'image/jpeg', jpe => 'image/jpeg', png => 'image/png', bmp => 'image/bmp', tiff => 'image/tiff', tif => 'image/tiff', jp2 => 'image/jp2', jpf => 'image/jpx', jpm => 'image/jpm',
	mp2 => 'audio/mpeg', mp3 => 'audio/mpeg', au => 'audio/au', aif => 'audio/x-aiff', wav => 'audio/wav',
	mpeg => 'video/mpeg', mpg => 'video/mpeg', mpe => 'video/mpeg', qt => 'video/quicktime', mov => 'video/quicktime', avi => 'video/x-msvideo', mj2 => 'video/mj2',
	rtf => 'application/rtf', doc => 'application/vnd.ms-word', wri => 'application/vnd.ms-word', xls => 'application/vnd.ms-excel', ppt => 'application/vnd.ms-powerpoint',
	pdf => 'application/pdf', ps => 'application/ps', eps => 'application/ps', zip => 'application/zip', other => 'application/octet-stream'
);

sub add_mimetypes
{
	open M, '/etc/mime.types' or return;

	while (<M>)
	{
		s/#.*$//, s/^\s+//, s/\s+$//; next unless $_;
		my ($mimetype, $ext) = /^(\S+)\s+(.*)$/; next unless $ext;
		$mimetype{$_} = $mimetype for split /\s+/, $ext;
	}

	close M;
}

sub tnef2mime
{
	my $m = shift;
	return $m unless exists $m->{mime_type} && $m->{mime_type} =~ /^multipart\//i && exists $m->{mime_parts};
	add_mimetypes() unless exists $mimetype{other};
	@{$m->{mime_parts}} = grep { defined $_ } map { (mimetype($_) =~ /^application\/ms-tnef/i && filename($_) =~ /winmail\.dat$/i) ? winmail($_) : $_ } @{$m->{mime_parts}};
	return $m;
}

sub MESSAGE { 1 }
sub ATTACHMENT { 2 }
sub MESSAGE_CLASS { 0x00078008 }
sub ATTACH_ATTACHMENT { 0x00069005 }
sub ATTACH_DATA { 0x0006800f }
sub ATTACH_FILENAME { 0x00018010 }
sub ATTACH_RENDDATA { 0x00069002 }
sub ATTACH_MODIFIED { 0x00038013 }
my $data; my @attachment; my $attachment; my $pos; my $badtnef;

sub winmail
{
	sub read_message_attribute
	{
		my $type = unpack 'C', substr $data, $pos, 1;
		return 0 unless defined $type && $type == MESSAGE; ++$pos;
		my $id = unpack 'V', substr $data, $pos, 4; $pos += 4;
		my $len = unpack 'V', substr $data, $pos, 4; $pos += 4;
		++$badtnef, return 0 if $pos + $len > length $data;
		my $buf = substr $data, $pos, $len; $pos += $len;
		my $chk = unpack 'v', substr $data, $pos, 2; $pos += 2;
		my $tot = unpack '%16C*', $buf;
		++$badtnef unless $chk == $tot;
		return $chk == $tot;
	}

	sub read_attribute_message_class
	{
		my $type = unpack 'C', substr $data, $pos, 1;
		return unless defined $type && $type == MESSAGE;
		my $id = unpack 'V', substr $data, $pos + 1, 4;
		return unless $id == MESSAGE_CLASS; $pos += 5;
		my $len = unpack 'V', substr $data, $pos, 4; $pos += 4;
		++$badtnef, return if $pos + $len > length $data;
		my $buf = substr $data, $pos, $len; $pos += $len;
		my $chk = unpack 'v', substr $data, $pos, 2; $pos += 2;
		my $tot = unpack '%16C*', $buf;
		++$badtnef unless $chk == $tot;
	}

	sub read_attachment_attribute
	{
		my $type = unpack 'C', substr $data, $pos, 1;
		return 0 unless defined $type && $type == ATTACHMENT; ++$pos;
		my $id = unpack 'V', substr $data, $pos, 4; $pos += 4;
		++$badtnef if $id == ATTACH_RENDDATA && @attachment && !exists $attachment->{body};
		push @attachment, $attachment = {} if $id == ATTACH_RENDDATA;
		my $len = unpack 'V', substr $data, $pos, 4; $pos += 4;
		++$badtnef, return 0 if $pos + $len > length $data;
		my $buf = substr $data, $pos, $len; $pos += $len;
		my $chk = unpack 'v', substr $data, $pos, 2; $pos += 2;
		my $tot = unpack '%16C*', $buf;
		++$badtnef, return 0 unless $chk == $tot;
		$attachment->{body} = $buf, $attachment->{size} = length $buf if $id == ATTACH_DATA;
		$buf =~ s/\x00+$//, $attachment->{filename} = $buf, $attachment->{type} = $mimetype{($attachment->{filename} =~ /\.([^.]+)$/) || 'other'} || 'application/octet-stream' if $id == ATTACH_FILENAME && !exists $attachment->{filename};
		my $fname; $attachment->{filename} = $fname, $attachment->{type} = $mimetype{($attachment->{filename} =~ /\.([^.]+)$/) || 'other'} || 'application/octet-stream' if $id == ATTACH_ATTACHMENT && ($fname = realname($buf));
		use POSIX; sub word { unpack 'v', substr($_[0], $_[1] * 2, 2) }
		$attachment->{modified} = strftime '%a, %d %b %Y %H:%M:%S +0000', gmtime mktime word($buf, 5), word($buf, 4), word($buf, 3), word($buf, 2), word($buf, 1) - 1, word($buf, 0) - 1900 if $id == ATTACH_MODIFIED;
		return 1;
	}

	sub realname
	{
		my $buf = shift;
		my $pos = index $buf, "\x1e\x00\x01\x30\x01"; return unless $pos >= 0; $pos += 8;
		my $len = unpack 'V', substr($buf, $pos, 4); $pos += 4;
		my $name = substr($buf, $pos, $len) or return;
		$name =~ s/\x00+$//;
		return $name;
	}

	my $m = shift;
	$pos = 0; $data = body($m); @attachment = (); $badtnef = 0;
	my $signature = unpack 'V', substr($data, $pos, 4); $pos += 4;
	return $m unless $signature == 0x223E9F78;
	my $key = unpack 'v', substr($data, $pos, 2); $pos += 2;
	my $type = unpack 'C', substr($data, $pos, 1);
	return $m unless $type == MESSAGE || $type == ATTACHMENT;
	do {} while read_message_attribute();
	read_attribute_message_class();
	do {} while read_message_attribute();
	do {} while read_attachment_attribute();
	++$badtnef if @attachment && !exists $attachment->{body};
	return ($badtnef) ? $m : map { newmail(%$_) } @attachment;
}

#ifdef TEST

my $test = $ARGV[0] || '';

if ($test =~ /help/ || $test =~ /-h/)
{
	print "$0 [command]\n";
	print "commands:\n";
	print "  $0 build         - Test header manipulation\n";
	print "  $0 header        - Test decoding of encoded headers\n";
	print "  $0 param         - Test parsing of nasty header parameters\n";
	print "  $0 mimetype      - Test mimetype identification and defaults\n";
	print "  $0 encoding      - Test encoding identification and defaults\n";
	print "  $0 filename      - Test filename identification and cleanup\n";
	print "  $0 newheader     - Test creating encoded headers\n";
	print "  $0 newparam      - Test creating encoded parameters\n";
	print "  $0 newmail       - Test creating mail objects\n";
	print "  $0    < in > out - Test parser: \"identity\" mbox filter (default)\n";
	print "  $0 m  < in > out - Test parser: mbox filter with mail2multipart\n";
	print "  $0 s  < in > out - Test parser: mbox filter with mail2singlepart\n";
	print "  $0 sm < in > out - Test parser: mbox filter with both (multi then single)\n";
	print "\n";
	print "Type \"perldoc -F $0\" for the API manpage\n";
	print "\n";
	exit;
}

if ($test eq 'build')
{
	my $mail = {};
	append_header($mail, 'To: xxx@to.org');
	insert_header($mail, 'From: from@from.org');
	append_header($mail, 'Subject: subject');
	insert_header($mail, 'X-X: test');
	use POSIX; append_header($mail, 'Date: ' . ctime(time));
	replace_header($mail, 'To: to@to.org');
	delete_header($mail, 'x-x');
	print mail2str($mail);
	print "header(\$m, 'from') = ", header($mail, 'from'), "\n";
	print "header(\$m, 'to') = ", header($mail, 'to'), "\n";
	print "header(\$m, 'subject') = ", header($mail, 'subject'), "\n";
	print "header(\$m, 'date') = ", header($mail, 'date'), "\n";
	print "header_names(\$m) = (", join(', ', sort(&header_names($mail))), ")\n";
	print "header(\$m) =\n  ", join("\n  ", sort(&headers($mail))), "\n";
	exit;
}

if ($test eq 'header')
{
	print $_, header_display($_), "\n" for
	(
		"Header: (this is a \\(nested\\) comment) =?US-ASCII?Q?Keith_Moore_?= =?ISO-8859-1?Q?Keld_J=F8rn_Simonsen?=\n",
		"Content-Type: multipart/mixed; (this is a \\(nested\\) comment) param=\"va(not a comment)lue\"\n",
		"Subject: =?ISO-8859-1?B?SWYgeW91IGNhbiByZWFkIHRoaXMgeW8=?= =?ISO-8859-2?B?dSB1bmRlcnN0YW5kIHRoZSBleGFtcGxlLg==?=\n"
	);
	exit;
}

if ($test eq 'param')
{
	my $m = {};
	append_header($m, (my $h = "Content-Type: multipart/mixed; boundary*0*=\"iso-8859-1'en'%61a%61\" boundary*2=ccc boundary*1*=%62b%62"));
	print "$h\nparam(\$m, 'content-type', 'boundary') = ", param($m, 'content-type', 'boundary'), "\n";
	exit;
}

if ($test eq 'mimetype')
{
	my $m = {};
	append_header($m, "Content-Transfer-Encoding: wierd");
	append_header($m, "Content-Type: image/png");
	print "unknown encoding: ", mimetype($m), "\n";
	replace_header($m, "Content-Transfer-Encoding: 7bit");
	print "explicit type: ", mimetype($m), "\n";
	replace_header($m, "Content-Type: invalid/junk");
	print "invalid type: ", mimetype($m), "\n";
	my $p = { mime_type => 'multipart/digest'};
	delete_header($m, 'Content-Type');
	print "default type in digest: ", mimetype($m, $p), "\n";
	print "default type elsewhere: ", mimetype($m), "\n";
	exit;
}

if ($test eq 'encoding')
{
	my $m = {};
	$m->{body} = "hi\n";
	print "default encoding (7bit): ", encoding($m), "\n";
	$m->{body} = "hi\xff\n";
	print "default encoding (8bit): ", encoding($m), "\n";
	replace_header($m, "Content-Transfer-Encoding: wierd");
	$m->{body} = "hi\n";
	print "unknown encoding (7bit): ", encoding($m), "\n";
	$m->{body} = "hi\xff\n";
	print "unknown encoding (8bit): ", encoding($m), "\n";
	replace_header($m, "Content-Transfer-Encoding: 7bit");
	print "explicit encoding (7bit): ", encoding($m), "\n";
	replace_header($m, "Content-Transfer-Encoding: 8bit");
	print "explicit encoding (8bit): ", encoding($m), "\n";
	replace_header($m, "Content-Transfer-Encoding: BinAry");
	print "explicit encoding (bin): ", encoding($m), "\n";
	replace_header($m, "Content-Transfer-Encoding: Quoted-Printable");
	print "explicit encoding (qp): ", encoding($m), "\n";
	replace_header($m, "Content-Transfer-Encoding: BASE64");
	print "explicit encoding (b64): ", encoding($m), "\n";
	exit;
}

if ($test eq 'filename')
{
	my $m = {};
	append_header($m, (my $h = "Content-Type: text/plain; name=\"abc.txt\""));
	print "$h\nfilename() = ", filename($m), "\n\n";
	replace_header($m, ($h = "Content-Disposition: attachment; filename*0*=\"iso-8859-1'en_AU'C:\\\\a\\\\b\\\\c\\\\I'd tried to put lots\$ of !spaces\" filename*1*=\" &and (punctuation) and an escape %1b character in this filename.doc\""));
	print "$h\nfilename() = ", filename($m), "\n\n";
	exit;
}

if ($test eq 'newheader')
{
	my $m = {};
	append_header($m, 'Header1: text with öne non-ascii char for qp');
	append_header($m, 'Header2: text with lööööööööööööööööööööööööööööts of non-ascii chars for b64');
	append_header($m, 'Header3: text with a loooooooooooooooooooooooooooöooooooooooooooooooooooong word with 1 non-ascii char for split qp');
	append_header($m, 'Header4: text with a löööööööööööööööööööööööööööööööööööööööööööööööööööñg word of non-ascii chars for split b64');
	print mail2str($m);
	print 'Header1: ', header($m, 'header1'), "\n";
	print 'Header2: ', header($m, 'header2'), "\n";
	print 'Header3: ', header($m, 'header3'), "\n";
	print 'Header4: ', header($m, 'header4'), "\n";
	exit;
}

if ($test eq 'newparam')
{
	my $m = {};
	append_header($m, 'Content-type: text/plain' .
		newparam('charset', 'us-ascii') .
		newparam('filename', 'he he he') .
		newparam('name', 'hé hé') .
		newparam('long1', '123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890') .
		newparam('long2', '123456789 123456789 123456789 123456789 123456789 123456789 123456789 123456789 123456789 ') .
		newparam('french', 'Ceci est un exemple très simple mais un peu long et avec un accent grave sur deux è', 'fr')
	);
	print mail2str($m);
	print 'charset = ', param($m, 'content-type', 'charset'), "\n";
	print 'filename = ', param($m, 'content-type', 'filename'), "\n";
	print 'name = ', param($m, 'content-type', 'name'), "\n";
	print 'long1 = ', param($m, 'content-type', 'long1'), "\n";
	print 'long2 = ', param($m, 'content-type', 'long2'), "\n";
	print 'french = ', param($m, 'content-type', 'french'), "\n";
	exit;
}

if ($test eq 'newmail')
{
	print mail2str mail2mbox newmail(To => 'to@to.org', From => 'from@from.org', Subject => 'plain', body => "hello mail\n");
	print mail2str mail2mbox newmail(To => 'to@to.org', From => 'from@from.org', Subject => 'latin1', body => "hello maîl\n");
	print mail2str mail2mbox newmail(To => 'to@to.org', From => 'from@from.org', Subject => 'ctrl', body => "help me \x1b");
	print mail2str mail2mbox newmail(To => 'to@to.org', From => 'from@from.org', Subject => 'plain longline', body => 'x' x 999 . "\n");
	print mail2str mail2mbox newmail(To => 'to@to.org', From => 'from@from.org', Subject => 'latin1 longline no newline', body => 'Â' . 'x' x 998);
	print mail2str mail2mbox newmail(To => 'to@to.org', From => 'from@from.org', Subject => 'parts', parts => [newmail(body => "hello\n"), newmail(body => "hëllô\n", filename => 'latin.txt'), newmail(body => "\x1b", filename=> 'escape.dat')]);
	print mail2str mail2mbox newmail(To => 'to@to.org', From => 'from@from.org', Subject => 'msg', message => newmail(qw(To to From from Subject nested), body => "hello\n"));
	print mail2str mail2mbox newmail(To => 'to@to.org', From => 'from@from.org', Subject => 'digest', type => 'multipart/digest', parts => [newmail(message => newmail(Subject => 'a', body => "hello\n")), newmail(message => newmail(Subject => 'b', body => "hëllô\n")), newmail(message => newmail(Subject => 'c', body => "\x1b\n"))]);
	my $m = mail2mbox newmail(qw(To to@to.org From from@from.org Subject parts), parts => []);
	append_part($m, newmail(body => "hello\n"));
	append_part($m, newmail(body => "hëllô\n", filename => 'latin.txt'));
	append_part($m, newmail(body => "\x1b", filename=> 'escape.dat'));
	print mail2str($m);
	print mail2str(mail2mbox(newmail(qw(To to From from), filename => $0)));
	exit;
}

{
	sub rd { <> }
	sub pr { print mail2str mail2mbox shift }
	sub prm { print mail2str mail2multipart shift }
	sub prs { print mail2str mail2singlepart shift }
	sub prsm { print mail2str mail2singlepart mail2multipart shift }
	my $cmd = shift @ARGV if @ARGV && $ARGV[0] =~ /^(?:m|s|sm)$/;
	formail \&rd, \&pr if !defined $cmd;
	formail \&rd, \&prm if defined $cmd && $cmd eq 'm';
	formail \&rd, \&prs if defined $cmd && $cmd eq 's';
	formail \&rd, \&prsm if defined $cmd && $cmd eq 'sm';
	exit;
}

#endif

# vi:set ts=4 sw=4: