package Debbugs::MIME;
+=encoding utf8
+
=head1 NAME
Debbugs::MIME -- Mime handling routines for debbugs
use warnings;
use strict;
-use base qw(Exporter);
-use vars qw($VERSION @EXPORT_OK);
+use Exporter qw(import);
+use vars qw($DEBUG $VERSION @EXPORT_OK %EXPORT_TAGS @EXPORT);
BEGIN {
$VERSION = 1.00;
-
- @EXPORT_OK = qw(parse decode_rfc1522 encode_rfc1522 convert_to_utf8 create_mime_message getmailbody);
+ $DEBUG = 0 unless defined $DEBUG;
+
+ @EXPORT = ();
+
+ %EXPORT_TAGS = (mime => [qw(parse create_mime_message getmailbody),
+ qw(parse_to_mime_entity),
+ ],
+ rfc1522 => [qw(decode_rfc1522 encode_rfc1522)],
+ );
+ @EXPORT_OK=();
+ Exporter::export_ok_tags(keys %EXPORT_TAGS);
+ $EXPORT_TAGS{all} = [@EXPORT_OK];
}
-use File::Path;
-use File::Temp qw();
+use File::Path qw(remove_tree);
+use File::Temp qw(tempdir);
use MIME::Parser;
use POSIX qw(strftime);
-use List::MoreUtils qw(apply);
+use List::AllUtils qw(apply);
-# for decode_rfc1522
-use MIME::WordDecoder qw();
-use Encode qw(decode encode encode_utf8 decode_utf8 is_utf8);
+# for convert_to_utf8
+use Debbugs::UTF8 qw(convert_to_utf8);
-# for encode_rfc1522
+# for decode_rfc1522 and encode_rfc1522
+use Encode qw(decode encode encode_utf8 decode_utf8 is_utf8);
use MIME::Words qw();
sub getmailbody
if ($type eq 'text/plain' or
($type =~ m#text/?# and $type ne 'text/html') or
$type eq 'application/pgp') {
- return $entity->bodyhandle;
+ return $entity;
} elsif ($type eq 'multipart/alternative') {
# RFC 2046 says we should use the last part we recognize.
for my $part (reverse $entity->parts) {
return undef;
}
+=head2 parse_to_mime_entity
+
+ $entity = parse_to_mime_entity($record);
+
+Returns a MIME::Entity from a record (from Debbugs::Log), a filehandle, or a
+scalar mail message. Will die upon failure.
+
+Intermediate parsing results will be output under a temporary directory which
+should be cleaned up upon process exit.
+
+=cut
+
+sub parse_to_mime_entity {
+ my ($record) = @_;
+ my $parser = MIME::Parser->new();
+ my $entity;
+ # this will be cleaned up once we exit
+ my $tempdir = File::Temp->newdir();
+ $parser->output_dir($tempdir->dirname());
+ if (ref($record) eq 'HASH') {
+ if ($record->{inner_file}) {
+ $entity = $parser->parse($record->{fh}) or
+ die "Unable to parse entity";
+ } else {
+ $entity = $parser->parse_data($record->{text}) or
+ die "Unable to parse entity";
+ }
+ } elsif (ref($record)) {
+ $entity = $parser->parse($record) or
+ die "Unable to parse entity";
+ } else {
+ $entity = $parser->parse_data($record) or
+ die "Unable to parse entity";
+ }
+ return $entity;
+}
+
sub parse
{
# header and decoded body respectively
my (@headerlines, @bodylines);
my $parser = MIME::Parser->new();
- my $tempdir = File::Temp::tempdir();
+ my $tempdir = tempdir(CLEANUP => 1);
$parser->output_under($tempdir);
my $entity = eval { $parser->parse_data($_[0]) };
@headerlines = @{$entity->head->header};
chomp @headerlines;
- my $entity_body = getmailbody($entity);
- @bodylines = $entity_body ? $entity_body->as_lines() : ();
+ my $entity_body = getmailbody($entity);
+ my $entity_body_handle;
+ my $charset;
+ if (defined $entity_body) {
+ $entity_body_handle = $entity_body->bodyhandle();
+ $charset = $entity_body->head()->mime_attr('content-type.charset');
+ }
+ @bodylines = $entity_body_handle ? $entity_body_handle->as_lines() : ();
+ @bodylines = map {convert_to_utf8($_,$charset)} @bodylines;
chomp @bodylines;
} else {
# Legacy pre-MIME code, kept around in case MIME::Parser fails.
my @msg = split /\n/, $_[0];
my $i;
+ # assume us-ascii unless charset is set; probably bad, but we
+ # really shouldn't get to this point anyway
+ my $charset = 'us-ascii';
for ($i = 0; $i <= $#msg; ++$i) {
$_ = $msg[$i];
last unless length;
++$i;
$_ .= "\n" . $msg[$i];
}
+ if (/charset=\"([^\"]+)\"/) {
+ $charset = $1;
+ }
push @headerlines, $_;
}
-
- @bodylines = @msg[$i .. $#msg];
+ @bodylines = map {convert_to_utf8($_,$charset)} @msg[$i .. $#msg];
}
- rmtree $tempdir, 0, 1;
+ remove_tree($tempdir,{verbose => 0, safe => 1});
# Remove blank lines.
shift @bodylines while @bodylines and $bodylines[0] !~ /\S/;
die "The third argument to create_mime_message must be an arrayref" unless ref($attachments) eq 'ARRAY';
if ($include_date) {
- my %headers = apply {lc($_)} @{$headers};
+ my %headers = apply {defined $_ ? lc($_) : ''} @{$headers};
if (not exists $headers{date}) {
push @{$headers},
('Date',
# MIME::Entity is stupid, and doesn't rfc1522 encode its headers, so we do it for it.
my $msg = MIME::Entity->build('Content-Type' => 'text/plain; charset=utf-8',
'Encoding' => 'quoted-printable',
- (map{encode_rfc1522($_)} @{$headers}),
- Data => $body
+ (map{encode_rfc1522(encode_utf8(defined $_ ? $_:''))} @{$headers}),
+ Data => encode_utf8($body),
);
# Attach the attachments
}
-# Bug #61342 et al.
-
-sub convert_to_utf8 {
- my ($data, $charset) = @_;
- # raw data just gets returned (that's the charset WordDecorder
- # uses when it doesn't know what to do)
- return $data if $charset eq 'raw' or is_utf8($data,1);
- my $result;
- eval {
- # this encode/decode madness is to make sure that the data
- # really is valid utf8 and that the is_utf8 flag is off.
- $result = encode("utf8",decode($charset,$data))
- };
- if ($@) {
- warn "Unable to decode charset; '$charset' and '$data': $@";
- return $data;
- }
- return $result;
-}
=head2 decode_rfc1522
=cut
-BEGIN {
- # Set up the default RFC1522 decoder, which turns all charsets that
- # are supported into the appropriate UTF-8 charset.
- MIME::WordDecoder->default(new MIME::WordDecoder(
- ['*' => \&convert_to_utf8,
- ]));
-}
-
sub decode_rfc1522 {
my ($string) = @_;
# this is craptacular, but leading space is hacked off by unmime.
# Save it.
my $leading_space = '';
- $leading_space = $1 if $string =~ s/^(\s+)//;
- # unmime calls the default MIME::WordDecoder handler set up at
- # initialization time.
- return $leading_space . MIME::WordDecoder::unmime($string);
+ $leading_space = $1 if $string =~ s/^(\ +)//;
+ # we must do this to switch off the utf8 flag before calling decode_mimewords
+ $string = encode_utf8($string);
+ my @mime_words = MIME::Words::decode_mimewords($string);
+ my $tmp = $leading_space .
+ join('',
+ (map {
+ if (@{$_} > 1) {
+ convert_to_utf8(${$_}[0],${$_}[1]);
+ } else {
+ decode_utf8(${$_}[0]);
+ }
+ } @mime_words)
+ );
+ return $tmp;
}
=head2 encode_rfc1522
# handle being passed undef properly
return undef if not defined $rawstr;
+
+ # convert to octets if we are given a string in perl's internal
+ # encoding
+ $rawstr= encode_utf8($rawstr) if is_utf8($rawstr);
# We process words in reverse so we can preserve spacing between
# encoded words. This regex splits on word|nonword boundaries and
# nonword|nonword boundaries. We also consider parenthesis and "
if (length $encoded > 75) {
# Turn utf8 into the internal perl representation
# so . is a character, not a byte.
- my $tempstr = decode_utf8($word,Encode::FB_DEFAULT);
+ my $tempstr = is_utf8($word)?$word:decode_utf8($word,Encode::FB_DEFAULT);
my @encoded;
# Strip it into 10 character long segments, and encode
# the segments
projects / debbugs.git / blobdiff