| Subject: | Mail::Message::Body::File corrupts binary files |
The attached error.pl creates an example binary file and prints a hex dump of the result. The final 0D0A is lost.
There are two issues: Mail::Message::Body::File fails to set binmode before reading/writing files as appropriate and Mail::Message::Body::init() doesn't resolve the mime_type (and know if the file is binary or not) before acquiring the file data.
The attached patches are a somewhat brute-force approach I took just to get it working temporarily, but may be useful to illustrate the issue.
| Subject: | Mail-Message-Body-File.patch |
--- C:\strawberry\perl\site\lib\Mail\Message\Body\File.pm Sun Jan 05 12:51:19 2014
+++ \home\rse\lib\mail\message\body\file.pm Wed Jan 22 12:39:23 2014
@@ -37,6 +36,11 @@
return;
}
+ if( $self->mimeType->isBinary ) {
+ binmode IN;
+ binmode OUT;
+ }
+
my $nrlines = 0;
while(<IN>) { print OUT; $nrlines++ }
@@ -153,8 +157,10 @@
my $size = eval { -s $self->tempFilename };
- $size -= $self->nrLines
- if $Mail::Message::crlf_platform; # remove count for extra CR's
+ unless( $self->mimeType->isBinary ) {
+ $size -= $self->nrLines
+ if $Mail::Message::crlf_platform; # remove count for extra CR's
+ }
$self->{MMBF_size} = $size;
}
@@ -169,6 +175,10 @@
open IN, '<', $file
or die "Cannot read from $file: $!\n";
+ if( $self->mimeType->isBinary ) {
+ binmode IN;
+ }
+
my $return = join '', <IN>;
close IN;
@@ -184,6 +194,10 @@
open IN, '<', $file
or die "Cannot read from $file: $!\n";
+ if( $self->mimeType->isBinary ) {
+ binmode IN;
+ }
+
my @r = <IN>;
close IN;
@@ -192,7 +206,15 @@
}
sub file()
-{ open my $tmp, '<', shift->tempFilename;
+{
+ my $self = shift;
+
+ open my $tmp, '<', $self->tempFilename;
+
+ if( $self->mimeType->isBinary ) {
+ binmode $tmp;
+ }
+
$tmp;
}
@@ -207,6 +229,10 @@
open IN, '<', $file
or croak "Cannot read from $file: $!\n";
+ if( $self->mimeType->isBinary ) {
+ binmode IN;
+ }
+
if(ref $fh eq 'GLOB') {print $fh $_ while <IN>}
else {$fh->print($_) while <IN>}
close IN;
| Subject: | Mail-Message-Body.patch |
--- C:\strawberry\perl\site\lib\Mail\Message\Body.pm Sun Jan 05 12:51:19 2014
+++ \home\rse\lib\mail\message\body.pm Wed Jan 22 12:31:46 2014
@@ -63,44 +63,13 @@
$self->{MMB_modified} = $args->{modified} || 0;
- my $filename;
- if(defined(my $file = $args->{file}))
- {
- if(!ref $file)
- { $self->_data_from_filename($file) or return;
- $filename = $file;
- }
- elsif(ref $file eq 'GLOB')
- { $self->_data_from_glob($file) or return }
- elsif($file->isa('IO::Handle'))
- { $self->_data_from_filehandle($file) or return }
- else
- { croak "message body: illegal datatype `".ref($file)."' for file option" }
- }
- elsif(defined(my $data = $args->{data}))
- {
- if(!ref $data)
- { my @lines = split /^/, $data;
- $self->_data_from_lines(\@lines)
- }
- elsif(ref $data eq 'ARRAY')
- { $self->_data_from_lines($data) or return;
- }
- else
- { croak "message body: illegal datatype `".ref($data)."' for data option" }
- }
- elsif(! $self->isMultipart && ! $self->isNested)
- { # Neither 'file' nor 'data', so empty body.
- $self->_data_from_lines( [] ) or return;
- }
-
# Set the content info
my ($mime, $transfer, $disp, $charset, $descr, $cid) = @$args{
qw/mime_type transfer_encoding disposition charset
description content_id/ };
- if(defined $filename)
+ if(defined(my $filename = $args->{file}))
{ $disp = Mail::Message::Field->new
('Content-Disposition' => (-T $filename ? 'inline':'attachment')
, filename => basename($filename)
@@ -144,6 +113,35 @@
$self->type($mime);
$self->{MMB_eol} = $args->{eol} || 'NATIVE';
+
+ if(defined(my $file = $args->{file}))
+ {
+ if(!ref $file)
+ { $self->_data_from_filename($file) or return; }
+ elsif(ref $file eq 'GLOB')
+ { $self->_data_from_glob($file) or return }
+ elsif($file->isa('IO::Handle'))
+ { $self->_data_from_filehandle($file) or return }
+ else
+ { croak "message body: illegal datatype `".ref($file)."' for file option" }
+ }
+ elsif(defined(my $data = $args->{data}))
+ {
+ if(!ref $data)
+ { my @lines = split /^/, $data;
+ $self->_data_from_lines(\@lines)
+ }
+ elsif(ref $data eq 'ARRAY')
+ { $self->_data_from_lines($data) or return;
+ }
+ else
+ { croak "message body: illegal datatype `".ref($data)."' for data option" }
+ }
+ elsif(! $self->isMultipart && ! $self->isNested)
+ { # Neither 'file' nor 'data', so empty body.
+ $self->_data_from_lines( [] ) or return;
+ }
+
# Set message where the body belongs to.
| Subject: | error.pl |
use Mail::Message;
$test = "\xFF\x0a\xFF\x0d\xFF\x0a\x0d\xFF\x0d\x0a\xFF";
open OUT, '>', 'example.dat';
binmode OUT;
print OUT $test;
close OUT;
$mail = Mail::Message->build(
From => 'me@example.com',
To => 'you@example.com',
Subject => 'Bug in Mail::Message::Body::File',
data => ['See attached file']
);
$body = $mail->body;
$body = $body->attach( Mail::Message::Body->new(
file => 'example.dat',
mime_type => 'application/octet-stream'
) );
$mail->body($body);
open OUT, '>', 'example.mail';
$mail->print( \*OUT );
close OUT;
open IN, '<', 'example.mail';
$newmail = Mail::Message->read( \*IN );
close IN;
@parts = $newmail->parts;
print "- - - - - - - - - - - - - - - - -\n";
for (@parts) {
$data = $_->decoded();
hexdump( $data );
print "- - - - - - - - - - - - - - - - -\n";
}
hexdump($test);
sub hexdump {
my $data = shift;
while( length $data ) {
$line = substr $data, 0, 16, '';
$hex = unpack 'H*', $line;
$line =~ tr/\x20-\x7e/./c;
printf "%-32s | %s\n", $hex, $line;
}
}