use lib "./t";
use MIME::Entity;
use MIME::Parser;
use ExtUtils::TBone;
use Globby;
use strict;
my $line;
my $LINE;
#------------------------------------------------------------
# BEGIN
#------------------------------------------------------------
# Create checker:
my $T = typical ExtUtils::TBone;
$T->begin(29);
#------------------------------------------------------------
$T->msg("Testing build()");
#------------------------------------------------------------
{local $SIG{__WARN__} = sub { die "caught warning: ",@_ };
{
my $e = MIME::Entity->build(Path => "./testin/short.txt");
my $name = 'short.txt';
my $got;
#-----test------
$got = $e->head->mime_attr('content-type.name');
$T->ok($got eq $name,
"Path: with no Filename, got default content-type.name",
Got => $got);
#-----test------
$got = $e->head->mime_attr('content-disposition.filename');
$T->ok($got eq $name,
"Path: with no Filename, got default content-disp.filename",
Got => $got);
#-----test------
$got = $e->head->recommended_filename;
$T->ok($got eq $name,
"Path: with no Filename, got default recommended filename",
Got => $got);
}
{
#-----test------
my $e = MIME::Entity->build(Path => "./testin/short.txt",
Filename => undef);
my $got = $e->head->mime_attr('content-type.name');
$T->ok(!$got,
"Path: with explicitly undef Filename, got no filename",
Got => $got);
}
{
#-----test------
my $e = MIME::Entity->build(Path => "./testin/short.txt",
Filename => "foo.txt");
my $got = $e->head->mime_attr('content-type.name');
$T->ok($got eq "foo.txt",
"Path: verified explicit 'Filename'",
Got => $got);
}
{
#-----test------
my $e = MIME::Entity->build(Path => "./testin/sig"
);
my $got = $e->head->mime_attr('content-type');
$T->ok($got eq 'text/plain',
"Type: default ok",
Got => $got);
}
{
#-----test------
my $e = MIME::Entity->build(Path => "./testin/sig",
Type => "text/foo");
my $got = $e->head->mime_attr('content-type');
$T->ok($got eq 'text/foo',
"Type: explicit ok",
Got => $got);
}
{
#-----test------
my $e = MIME::Entity->build(Path => "./testin/sig",
Encoding => '-SUGGEST');
my $got = $e->head->mime_attr('content-transfer-encoding');
$T->ok($got eq '7bit',
"Encoding: -SUGGEST yields 7bit",
Got => $got);
}
{
#-----test------
my $e = MIME::Entity->build(Path => "./testin/short.txt",
Encoding => '-SUGGEST');
my $got = $e->head->mime_attr('content-transfer-encoding');
$T->ok($got eq 'quoted-printable',
"Encoding: -SUGGEST yields qp",
Got => $got);
}
{
#-----test------
my $e = MIME::Entity->build(Type => 'image/gif',
Path => "./testin/mime-sm.gif",
Encoding => '-SUGGEST');
my $got = $e->head->mime_attr('content-transfer-encoding');
$T->ok($got eq 'base64',
"Encoding: -SUGGEST yields base64",
Got => $got);
}
{
#-----test------
my $e = MIME::Entity->build(Path => "./testin/short.txt"
);
my $got = $e->head->mime_attr('content-type.charset');
$T->ok(!$got,
"Charset: default ok",
Got => $got);
}
{
#-----test------
my $e = MIME::Entity->build(Path => "./testin/short.txt",
Charset => 'iso8859-1');
my $got = $e->head->mime_attr('content-type.charset');
$T->ok($got eq 'iso8859-1',
"Charset: explicit",
Got => $got);
}
}
#------------------------------------------------------------
$T->msg("Create an entity");
#------------------------------------------------------------
# Create the top-level, and set up the mail headers in a couple
# of different ways:
my $top = MIME::Entity->build(Type => "multipart/mixed",
-From => "me\@myhost.com",
-To => "you\@yourhost.com");
$top->head->add('subject', "Hello, nurse!");
$top->preamble([]);
$top->epilogue([]);
# Attachment #0: a simple text document:
attach $top Path=>"./testin/short.txt";
# Attachment #1: a GIF file:
attach $top Path => "./testin/mime-sm.gif",
Type => "image/gif",
Encoding => "base64",
Disposition => "attachment";
# Attachment #2: a document we'll create manually:
my $attach = new MIME::Entity;
$attach->head(new MIME::Head ["X-Origin: fake\n",
"Content-transfer-encoding: quoted-printable\n",
"Content-type: text/plain\n"]);
$attach->bodyhandle(new MIME::Body::Scalar);
my $io = $attach->bodyhandle->open("w");
$io->print(<<EOF
This is the first line.
This is the middle.
This is the last.
EOF
);
$io->close;
$top->add_part($attach);
# Attachment #3: a document we'll create, not-so-manually:
$LINE = "This is the first and last line, with no CR at the end.";
$attach = attach $top Data=>$LINE;
#-----test------
$T->ok(1, "built a message");
unlink globby("testout/entity.msg*");
#------------------------------------------------------------
$T->msg("Check body");
#------------------------------------------------------------
my $bodylines = $top->parts(0)->body;
#-----test------
$T->ok($bodylines > 0,
"old-style body call ok");
my $preamble_str = join '', @{$top->preamble || []};
my $preamble_len = length($preamble_str);
my $epilogue_str = join '', @{$top->epilogue || []};
my $epilogue_len = length($epilogue_str);
#------------------------------------------------------------
$T->msg("Output msg1 to explicit filehandle glob");
#------------------------------------------------------------
open TMP, ">testout/entity.msg1" or die "open: $!";
$top->print(\*TMP);
close TMP;
#-----test------
$T->ok((-s "testout/entity.msg1"),
"wrote msg1 to filehandle glob");
#------------------------------------------------------------
$T->msg("Output msg2 to selected filehandle");
#------------------------------------------------------------
open TMP, ">testout/entity.msg2" or die "open: $!";
my $oldfh = select TMP;
$top->print;
select $oldfh;
close TMP;
#-----test------
$T->ok((-s "testout/entity.msg2"),
"write msg2 to selected filehandle");
#------------------------------------------------------------
$T->msg("Compare");
#------------------------------------------------------------
# Same?
$T->ok(((-s "testout/entity.msg1") == (-s "testout/entity.msg2")),
"message files are same length");
#------------------------------------------------------------
$T->msg("Parse it back in, to check syntax");
#------------------------------------------------------------
my $parser = new MIME::Parser;
$parser->output_dir("testout");
open IN, "./testout/entity.msg1" or die "open: $!";
$top = $parser->parse(\*IN);
$T->msg($parser->results->msgs);
#-----test------
$T->ok($top, "parsed msg1 back in");
my $preamble_str2 = join '', @{$top->preamble || []};
my $preamble_len2 = length($preamble_str2);
my $epilogue_str2 = join '', @{$top->epilogue || []};
my $epilogue_len2 = length($epilogue_str2);
#-----test------
$T->ok(($preamble_len == $preamble_len2),
"preambles match ($preamble_len == $preamble_len2)",
Pre1 => $preamble_str,
Pre2 => $preamble_str2,
);
#-----test------
$T->ok(($epilogue_len == $epilogue_len2),
"epilogues match ($epilogue_len == $epilogue_len2)",
Epi1 => $epilogue_str,
Epi2 => $epilogue_str2,
);
#------------------------------------------------------------
$T->msg("Check the number of parts");
#------------------------------------------------------------
$T->ok(($top->parts == 4),
"number of parts is correct (4)");
#------------------------------------------------------------
$T->msg("Check attachment 1 [the GIF]");
#------------------------------------------------------------
my $gif_real = (-s "./testin/mime-sm.gif");
my $gif_this = (-s "./testout/mime-sm.gif");
#-----test------
$T->ok(($gif_real == $gif_this),
"GIF is right size (real = $gif_real, this = $gif_this)");
my $part = ($top->parts)[1];
#-----test------
$T->ok(($part->head->mime_type eq 'image/gif'),
"GIF has correct MIME type");
#------------------------------------------------------------
$T->msg("Check attachment 3 [the short message]");
#------------------------------------------------------------
$part = ($top->parts)[3];
$io = $part->bodyhandle->open("r");
$line = ($io->getline);
$io->close;
#-----test------
$T->ok(($line eq $LINE),
"getline gets correct value (IO = $io, <$line>, <$LINE>)");
#-----test------
$T->ok(($part->head->mime_type eq 'text/plain'),
"MIME type okay");
#-----test------
$T->ok(($part->head->mime_encoding eq 'binary'),
"MIME encoding okay");
#------------------------------------------------------------
$T->msg("Write it out, and compare");
#------------------------------------------------------------
open TMP, ">testout/entity.msg3" or die "open: $!";
$top->print(\*TMP);
close TMP;
#-----test------
$T->ok(((-s "testout/entity.msg2") == (-s "testout/entity.msg3")),
"msg2 same size as msg3");
#------------------------------------------------------------
$T->msg("Duplicate");
#------------------------------------------------------------
my $dup = $top->dup;
open TMP, ">testout/entity.dup3" or die "open: $!";
$dup->print(\*TMP);
close TMP;
my $msg3_s = -s "testout/entity.msg3";
my $dup3_s = -s "testout/entity.dup3";
#-----test------
$T->ok(($msg3_s == $dup3_s),
"msg3 size ($msg3_s) is same as dup3 size ($dup3_s)");
#------------------------------------------------------------
$T->msg("Test signing");
#------------------------------------------------------------
$top->sign(File=>"./testin/sig");
$top->remove_sig;
$top->sign(File=>"./testin/sig2", Remove=>56);
$top->sign(File=>"./testin/sig3");
#------------------------------------------------------------
$T->msg("Write it out again, after synching");
#------------------------------------------------------------
$top->sync_headers(Nonstandard=>'ERASE',
Length=>'COMPUTE');
open TMP, ">testout/entity.msg4" or die "open: $!";
$top->print(\*TMP);
close TMP;
#------------------------------------------------------------
$T->msg("Purge the files");
#------------------------------------------------------------
$top->purge;
#-----test------
$T->ok((! -e "./testout/mime-sm.gif"),
"purge worked");
# Done!
exit(0);
1;