use Debbugs::Common qw(globify_scalar english_join);
use Debbugs::Config qw(:config);
use POSIX qw(strftime);
+use Encode qw(decode_utf8);
BEGIN{
($VERSION) = q$Revision: 494 $ =~ /^Revision:\s+([^\s+])/;
my $head = $entity->head;
chomp(my $type = $entity->effective_type);
my $body = $entity->stringify_body;
+ # this attachment has its own content type, so we must not
+ # try to convert it to UTF-8 or do anything funky.
+ my @layers = PerlIO::get_layers($param{output});
+ binmode($param{output},':raw');
print {$param{output}} "Content-Type: $type";
my ($charset) = $head->get('Content-Type:') =~ m/charset\s*=\s*\"?([\w-]+)\"?/i;
print {$param{output}} qq(; charset="$charset") if defined $charset;
- print {$param{output}}"\n";
+ print {$param{output}} "\n";
if ($filename ne '') {
my $qf = $filename;
$qf =~ s/"/\\"/g;
print {$param{output}} "\n";
my $decoder = MIME::Decoder->new($head->mime_encoding);
$decoder->decode(IO::Scalar->new(\$body), $param{output});
+ if (grep {/utf8/} @layers) {
+ binmode($param{output},':utf8');
+ }
return;
}
elsif (not exists $param{att}) {
my $content_type = $entity->head->get('Content-Type:') || "text/html";
my ($charset) = $content_type =~ m/charset\s*=\s*\"?([\w-]+)\"?/i;
my $body = $entity->bodyhandle->as_string;
- $body = convert_to_utf8($body,$charset) if defined $charset;
+ $body = convert_to_utf8($body,$charset//'utf8');
$body = html_escape($body);
# Attempt to deal with format=flowed
if ($content_type =~ m/format\s*=\s*\"?flowed\"?/i) {
sub handle_email_message{
my ($email,%param) = @_;
- my $output = '';
+ # output needs to have the is_utf8 flag on to avoid double
+ # encoding
+ my $output = decode_utf8('');
my $parser = MIME::Parser->new();
# Because we are using memory, not tempfiles, there's no need to
# clean up here like in Debbugs::MIME
sub handle_record{
my ($record,$bug_number,$msg_number,$seen_msg_ids) = @_;
- my $output = '';
+ # output needs to have the is_utf8 flag on to avoid double
+ # encoding
+ my $output = decode_utf8('');
local $_ = $record->{type};
if (/html/) {
- my ($time) = $record->{text} =~ /<!--\s+time:(\d+)\s+-->/;
- my $class = $record->{text} =~ /^<strong>(?:Acknowledgement|Reply|Information|Report|Notification)/m ? 'infmessage':'msgreceived';
- $output .= decode_rfc1522($record->{text});
+ # $record->{text} is not in perl's internal encoding; convert it
+ my $text = decode_utf8($record->{text});
+ my ($time) = $text =~ /<!--\s+time:(\d+)\s+-->/;
+ my $class = $text =~ /^<strong>(?:Acknowledgement|Reply|Information|Report|Notification)/m ? 'infmessage':'msgreceived';
+ $output .= decode_rfc1522($text);
# Link to forwarded http:// urls in the midst of the report
# (even though these links already exist at the top)
$output =~ s,((?:ftp|http|https)://[\S~-]+?/?)((?:[\)\'\:\.\,]|\&\#39;)?(?:\s|\.<|$)),<a href=\"$1\">$1</a>$2,go;
qw(cleanup_eval_fail),
qw(hash_slice),
],
+ utf8 => [qw(encode_utf8_structure)],
date => [qw(secs_to_english)],
quit => [qw(quit)],
lock => [qw(filelock unfilelock lockpid)],
);
@EXPORT_OK = ();
- Exporter::export_ok_tags(qw(lock quit date util misc));
+ Exporter::export_ok_tags(keys %EXPORT_TAGS);
$EXPORT_TAGS{all} = [@EXPORT_OK];
}
use Debbugs::MIME qw(decode_rfc1522);
use Mail::Address;
use Cwd qw(cwd);
+use Encode qw(encode_utf8 is_utf8);
+use Storable qw(dclone);
use Params::Validate qw(validate_with :types);
$type //= 'address';
my $fh = IO::File->new($fn,'r') or
die "Unable to open $fn for reading: $!";
+ binmode($fh,':encoding(UTF-8)');
while (<$fh>) {
chomp;
next unless m/^(\S+)\s+(\S.*\S)\s*$/;
if (defined ref($scalar)) {
if (ref($scalar) eq 'SCALAR' and
not UNIVERSAL::isa($scalar,'GLOB')) {
- return IO::Scalar->new($scalar);
+ open $handle, '>:scalar:utf8', $scalar;
+ return $handle;
}
else {
return $scalar;
carp "Given a non-scalar reference, non-glob to globify_scalar; returning /dev/null handle";
}
}
- return IO::File->new('/dev/null','w');
+ return IO::File->new('/dev/null','>:utf8');
}
=head2 cleanup_eval_fail()
return map {exists $hashref->{$_}?($_,$hashref->{$_}):()} @keys;
}
+
+=head1 UTF-8
+
+These functions are exported with the :utf8 tag
+
+=head2 encode_utf8_structure
+
+ %newdata = encode_utf8_structure(%newdata);
+
+Takes a complex data structure and encodes any strings with is_utf8
+set into their constituent octets.
+
+=cut
+
+our $depth = 0;
+sub encode_utf8_structure {
+ ++$depth;
+ my @ret;
+ for my $_ (@_) {
+ if (ref($_) eq 'HASH') {
+ push @ret, {encode_utf8_structure(%{$depth == 1 ? dclone($_):$_})};
+ }
+ elsif (ref($_) eq 'ARRAY') {
+ push @ret, [encode_utf8_structure(@{$depth == 1 ? dclone($_):$_})];
+ }
+ elsif (ref($_)) {
+ # we don't know how to handle non hash or non arrays
+ push @ret,$_;
+ }
+ else {
+ push @ret,__encode_utf8($_);
+ }
+ }
+ --$depth;
+ return @ret;
+}
+
+sub __encode_utf8 {
+ my @ret;
+ for my $r (@_) {
+ if (not ref($r) and is_utf8($r)) {
+ $r = encode_utf8($r);
+ }
+ push @ret,$r;
+ }
+ return @ret;
+}
+
+
+
1;
__END__
}
use Debbugs::Config qw(:config);
-use Debbugs::Common qw(:lock buglog :misc get_hashname sort_versions);
+use Debbugs::Common qw(:lock buglog :misc get_hashname sort_versions :utf8);
use Debbugs::Status qw(bug_archiveable :read :hook writebug new_bug splitpackages split_status_fields get_bug_status);
use Debbugs::CGI qw(html_escape);
use Debbugs::Log qw(:misc :write);
use Storable qw(dclone nfreeze);
use List::Util qw(first max);
+use Encode qw(encode_utf8);
use Carp;
headers =>
[To => $data->{submitter},
Subject => "$config{ubug}#$data->{bug_num} ".
- "closed by $param{requester} ($param{request_subject})",
+ "closed by $param{requester} ".(defined $param{request_subject}?"($param{request_subject})":""),
],
)
],
$nd{$key} = $new_data->{$key};
# $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $new_data->{$key}")."\n";
}
- $data_diff .= html_escape(Data::Dumper->Dump([\%nd],[qw(new_data)]));
+ $data_diff .= html_escape(Data::Dumper->Dump([encode_utf8_structure(\%nd)],[qw(new_data)]));
$data_diff .= "-->\n";
$data_diff .= "<!-- old_data:\n";
my %od;
$od{$key} = $old_data->{$key};
# $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $old_data->{$key}")."\n";
}
- $data_diff .= html_escape(Data::Dumper->Dump([\%od],[qw(old_data)]));
+ $data_diff .= html_escape(Data::Dumper->Dump([encode_utf8_structure(\%od)],[qw(old_data)]));
$data_diff .= "-->\n";
}
my $msg = join('',
(exists $param{command} ?
- "<!-- command:".html_escape($param{command})." -->\n":""
+ "<!-- command:".html_escape(encode_utf8($param{command}))." -->\n":""
),
(length $param{requester} ?
- "<!-- requester: ".html_escape($param{requester})." -->\n":""
+ "<!-- requester: ".html_escape(encode_utf8($param{requester}))." -->\n":""
),
(length $param{request_addr} ?
- "<!-- request_addr: ".html_escape($param{request_addr})." -->\n":""
+ "<!-- request_addr: ".html_escape(encode_utf8($param{request_addr}))." -->\n":""
),
"<!-- time:".time()." -->\n",
$data_diff,
- "<strong>".html_escape($param{action})."</strong>\n");
+ "<strong>".html_escape(encode_utf8($param{action}))."</strong>\n");
if (length $param{requester}) {
- $msg .= "Request was from <code>".html_escape($param{requester})."</code>\n";
+ $msg .= "Request was from <code>".html_escape(encode_utf8($param{requester}))."</code>\n";
}
if (length $param{request_addr}) {
- $msg .= "to <code>".html_escape($param{request_addr})."</code>";
+ $msg .= "to <code>".html_escape(encode_utf8($param{request_addr}))."</code>";
}
if (length $param{desc}) {
- $msg .= ":<br>\n$param{desc}\n";
+ $msg .= ":<br>\n".encode_utf8($param{desc})."\n";
}
else {
$msg .= ".\n";
use Debbugs::Common qw(getbuglocation getbugcomponent make_list);
use Params::Validate qw(:types validate_with);
-use Encode qw(encode);
+use Encode qw(encode is_utf8);
=head1 NAME
write the .log files used by debbugs to store the complete textual records
of all bug transactions.
+Debbugs::Log does not decode utf8 into perl's internal encoding or
+encode into utf8 from perl's internal encoding. For html records and
+all recips, this should probably be done. For other records, this should
+not be needed.
+
=head2 The .log File Format
.log files consist of a sequence of records, of one of the following four
for my $record (@records) {
my $type = $record->{type};
croak "record type '$type' with no text field" unless defined $record->{text};
+ # I am not sure if we really want to croak here; but this is
+ # almost certainly a bug if is_utf8 is on.
+ # croak "probably wrong encoding" if is_utf8($record->{text});
my ($text) = escape_log($record->{text});
if ($type eq 'autocheck') {
print {$logfh} "\01\n$text\03\n" or
sub escape_log {
my @log = @_;
- return map { eval {$_ = encode("utf8",$_,Encode::FB_CROAK)}; s/^([\01-\07\030])/\030$1/gm; $_ } @log;
+ return map {s/^([\01-\07\030])/\030$1/gm; $_ } @log;
}
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))
+ $result = decode($charset,$data);
};
if ($@) {
warn "Unable to decode charset; '$charset' and '$data': $@";
# handle being passed undef properly
return undef if not defined $rawstr;
+ if (is_utf8($rawstr)) {
+ $rawstr= encode_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
if ($param{encode_headers}) {
$param{message} = encode_headers($param{message});
}
- eval {
- if (is_utf8($param{message})) {
- $param{message} = encode('utf8',$param{message});
- }
- };
# First, try to send the message as is.
eval {
use warnings;
use strict;
use vars qw($DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
+use Debbugs::SOAP::Server;
use base qw(Exporter SOAP::Server::Parameters);
BEGIN{
}
-
use IO::File;
use Debbugs::Status qw(get_bug_status);
-use Debbugs::Common qw(make_list getbuglocation getbugcomponent);
+use Debbugs::Common qw(make_list getbuglocation getbugcomponent :utf8);
use Debbugs::Packages;
-use Storable qw(nstore retrieve);
+
+use Storable qw(nstore retrieve dclone);
use Scalar::Util qw(looks_like_number);
delete $ut{$tag} unless exists $tags{$tag};
}
}
- return \%ut;
+ return encode_utf8_structure(\%ut);
}
}
}
# __prepare_response($self);
- return \%status;
+ return encode_utf8_structure(\%status);
}
=head2 get_bugs
my %params = __collapse_params(@params);
my @bugs;
@bugs = Debbugs::Bugs::get_bugs(%params);
- return \@bugs;
+ return encode_utf8_structure(\@bugs);
}
=head2 newest_bugs
my $VERSION = __populate_version(pop);
my ($self,$num) = @_;
my $newest_bug = Debbugs::Bugs::newest_bug();
- return [($newest_bug - $num + 1) .. $newest_bug];
+ return encode_utf8_structure([($newest_bug - $num + 1) .. $newest_bug]);
}
msg_num => $current_msg,
};
}
- return \@messages;
+ return encode_utf8_structure(\@messages);
}
=head2 binary_to_source
my ($self,@params) = @_;
if ($VERSION <= 1) {
- return [Debbugs::Packages::binary_to_source(binary => $params[0],
+ return encode_utf8_structure([Debbugs::Packages::binary_to_source(binary => $params[0],
(@params > 1)?(version => $params[1]):(),
(@params > 2)?(arch => $params[2]):(),
- )];
+ )]);
}
else {
- return [Debbugs::Packages::binary_to_source(@params)];
+ return encode_utf8_structure([Debbugs::Packages::binary_to_source(@params)]);
}
}
my $VERSION = __populate_version(pop);
my ($self,@params) = @_;
- return [Debbugs::Packages::sourcetobinary(@params)];
+ return encode_utf8_structure([Debbugs::Packages::sourcetobinary(@params)]);
}
=head2 get_versions
my $VERSION = __populate_version(pop);
my ($self,@params) = @_;
- return scalar Debbugs::Packages::get_versions(@params);
+ return encode_utf8_structure(scalar Debbugs::Packages::get_versions(@params));
}
=head1 VERSION COMPATIBILITY
use base qw(Exporter);
use Params::Validate qw(validate_with :types);
-use Debbugs::Common qw(:util :lock :quit :misc);
+use Debbugs::Common qw(:util :lock :quit :misc :utf8);
use Debbugs::Config qw(:config);
use Debbugs::MIME qw(decode_rfc1522 encode_rfc1522);
use Debbugs::Packages qw(makesourceversions make_source_versions getversions get_versions binary_to_source);
use Debbugs::Versions::Dpkg;
use POSIX qw(ceil);
use File::Copy qw(copy);
-use Encode qw(decode encode);
+use Encode qw(decode encode is_utf8);
use Storable qw(dclone);
use List::Util qw(min max);
}
return undef;
}
+ binmode($status_fh,':encoding(UTF-8)');
my %data;
my @lines;
my %namemap = reverse %fields;
for my $line (@lines) {
- eval {
- $line = decode("utf8",$line,Encode::FB_CROAK);
- };
if ($line =~ /(\S+?): (.*)/) {
my ($name, $value) = (lc $1, $2);
# this is a bit of a hack; we should never, ever have \r
}
}
for my $field (keys %fields) {
- $data{$field} = '' unless exists $data{$field};
+ $data{$field} = '' unless exists $data{$field};
+ }
+ if ($version < 3) {
+ for my $field (@rfc1522_fields) {
+ $data{$field} = decode_rfc1522($data{$field});
+ }
}
-
$data{severity} = $config{default_severity} if $data{severity} eq '';
for my $field (qw(found_versions fixed_versions found_date fixed_date)) {
$data{$field} = [split ' ', $data{$field}];
@{$data{"${field}_date"}});
}
- if ($version < 3) {
- for my $field (@rfc1522_fields) {
- $data{$field} = decode_rfc1522($data{$field});
- }
- }
my $status_modified = (stat($status))[9];
# Add log last modified time
$data{log_modified} = (stat($log))[9];
sub makestatus {
my ($data,$version) = @_;
- $version = 2 unless defined $version;
+ $version = 3 unless defined $version;
my $contents = '';
}
%newdata = %{join_status_fields(\%newdata)};
+ %newdata = encode_utf8_structure(%newdata);
+
if ($version < 3) {
for my $field (@rfc1522_fields) {
$newdata{$field} = encode_rfc1522($newdata{$field});
}
}
}
- eval {
- $contents = encode("utf8",$contents,Encode::FB_CROAK);
- };
return $contents;
}
my ($ref, $data, $location, $minversion, $disablebughook) = @_;
my $change;
- my %outputs = (1 => 'status', 2 => 'summary');
+ my %outputs = (1 => 'status', 3 => 'summary');
for my $version (keys %outputs) {
next if defined $minversion and $version < $minversion;
my $status = getbugcomponent($ref, $outputs{$version}, $location);
die "can't find location for $ref" unless defined $status;
- open(S,"> $status.new") || die "opening $status.new: $!";
- print(S makestatus($data, $version)) ||
+ my $sfh;
+ if ($version >= 3) {
+ open $sfh,">","$status.new" or
+ die "opening $status.new: $!";
+ }
+ else {
+ open $sfh,">","$status.new" or
+ die "opening $status.new: $!";
+ }
+ print {$sfh} makestatus($data, $version) or
die "writing $status.new: $!";
- close(S) || die "closing $status.new: $!";
+ close($sfh) or die "closing $status.new: $!";
if (-e $status) {
$change = 'change';
} else {
ref(\$param{template}) eq 'GLOB') {
$tt_type = 'FILE_HANDLE';
$tt_source = $param{template};
+ binmode($tt_source,":encoding(UTF-8)");
}
elsif (ref($param{template}) eq 'SCALAR') {
$tt_type = 'STRING';
my $tt;
if ($tt_type eq 'FILE' and
defined $tt_templates{$tt_source} and
+ ($tt_templates{$tt_source}{mtime} + 60) < time and
(stat $tt_source)[9] <= $tt_templates{$tt_source}{mtime}
) {
$tt = $tt_templates{$tt_source}{template};
}
else {
+ my $passed_source = $tt_source;
+ my $passed_type = $tt_type;
if ($tt_type eq 'FILE') {
$tt_templates{$tt_source}{mtime} =
(stat $tt_source)[9];
+ $passed_source = IO::File->new($tt_source,'r');
+ binmode($passed_source,":encoding(UTF-8)");
+ $passed_type = 'FILEHANDLE';
}
- $tt = Text::Template->new(TYPE => $tt_type,
- SOURCE => $tt_source,
+ $tt = Text::Template->new(TYPE => $passed_type,
+ SOURCE => $passed_source,
UNTAINT => 1,
);
if ($tt_type eq 'FILE') {
delete @ENV{qw(IFS CDPATH ENV BASH_ENV)};
}
+# STDOUT should be using the utf8 io layer
+binmode(STDOUT,':utf8');
+
use POSIX qw(strftime);
use MIME::Parser;
use MIME::Decoder;
}
my @log;
if ( $mbox ) {
+ binmode(STDOUT,":raw");
my $date = strftime "%a %b %d %T %Y", localtime;
if (@records > 1) {
print $q->header(-type => "text/plain",
else {
if (defined $att and defined $msg and @records) {
+ binmode(STDOUT,":raw");
$msg_num++;
print handle_email_message($records[0]->{text},
ref => $ref,
delete @ENV{qw(IFS CDPATH ENV BASH_ENV)};
}
+# STDOUT should be in utf8 mode
+binmode(STDOUT,':utf8');
+
use POSIX qw(strftime nice);
use Debbugs::Config qw(:globals :text :config);
* affects now appends packages by default (closes: #656371). Thanks to
Andreas Beckmann and Julien Cristau.
* Fix spacing in owner block (closes: #670411)
+ * Fix double encoding issues (closes: #672432)
+ * Fix encoding in cgi
[Thanks to Arnout Engelen: ]
* Add Homepage (closes: #670555).
use Debbugs::Config qw(:globals :config);
use Debbugs::Control qw(append_action_to_log);
+use Encode qw(encode_utf8);
chdir( "$gSpoolDir" ) || die "chdir spool: $!\n";
}
if ($codeletter eq 'U') { # sent to -submitter
&htmllog("Message", "sent on", $data->{originator}, "$gBug#$ref.");
- &sendmessage(<<END,[$data->{originator},@resentccs],[@bccs]);
+ my $enc_msg=<<END;
Subject: $gBug#$ref: $newsubject
Reply-To: $replyto, $ref-quiet\@$gEmailDomain
${orgsender}Resent-To: $data->{originator}
X-$gProject-PR-Message: report $ref
X-$gProject-PR-Package: $data->{package}
X-$gProject-PR-Keywords: $data->{keywords}
-${source_pr_header}$fwd
+${source_pr_header}
END
+ chomp $enc_msg;
+ $enc_msg = encode_utf8($enc_msg).$fwd."\n";
+ &sendmessage($enc_msg,[$data->{originator},@resentccs],[@bccs]);
} elsif ($codeletter eq 'B') { # Sent to submit
my $report_followup = $newref ? 'report' : 'followup';
&htmllog($newref ? "Report" : "Information", "forwarded",
"<code>$gBug#$ref</code>".
(length($data->{package})? "; Package <code>".html_escape($data->{package})."</code>" : '').
".");
- &sendmessage(<<END,["$gSubmitList\@$gListDomain",@resentccs],[@bccs]);
+ my $enc_msg=<<END;
Subject: $gBug#$ref: $newsubject
Reply-To: $replyto, $ref\@$gEmailDomain
Resent-From: $header{'from'}
X-$gProject-PR-Message: $report_followup $ref
X-$gProject-PR-Package: $data->{package}
X-$gProject-PR-Keywords: $data->{keywords}
-${source_pr_header}$fwd
+${source_pr_header}
END
+ chomp $enc_msg;
+ $enc_msg = encode_utf8($enc_msg).$fwd."\n";
+ &sendmessage($enc_msg,["$gSubmitList\@$gListDomain",@resentccs],[@bccs]);
} elsif (@resentccs or @bccs) { # Quiet or Maintainer
# D and F done far earlier; B just done - so this must be M or Q
# We preserve whichever it was in the Reply-To (possibly adding
(length($data->{package}) ? "; Package <code>".html_escape($data->{package})."</code>" : '').
".");
}
- &sendmessage(<<END,[@resentccs],[@bccs]);
+ my $enc_msg=<<END;
Subject: $gBug#$ref: $newsubject
Reply-To: $replyto, $ref-$baddressroot\@$gEmailDomain
Resent-From: $header{'from'}
${common_headers}X-$gProject-PR-Message: $report_followup $ref
X-$gProject-PR-Package: $data->{package}
X-$gProject-PR-Keywords: $data->{keywords}
-${source_pr_header}$fwd
+${source_pr_header}
END
+ chomp $enc_msg;
+ $enc_msg = encode_utf8($enc_msg).$fwd."\n";
+ &sendmessage($enc_msg,[@resentccs],[@bccs]);
}
my $htmlbreak= length($brokenness) ? "<p>\n".html_escape($brokenness)."\n<p>\n" : '';
use warnings;
use strict;
-use utf8;
use Encode;
use_ok('Debbugs::MIME');
# encode_headers testing
-my $test_str = <<'END';
+my $test_str = decode_utf8(<<'END');
Döñ Ärḿßtrøñĝ <don@donarmstrong.com>
END
-my $test_str2 = <<'END';
+my $test_str2 = decode_utf8(<<'END');
Döñ Ärḿßtrøñĝ <don@donarmstrong.com>
END
-my $test_str3 =<<'END';
+my $test_str3 =decode_utf8(<<'END');
foo@bar.com (J fö"ø)
END
# 1: test decode
ok(Debbugs::MIME::decode_rfc1522(q(=?iso-8859-1?Q?D=F6n_Armstr=F3ng?= <don@donarmstrong.com>)) eq
- encode_utf8(q(Dön Armstróng <don@donarmstrong.com>)),"decode_rfc1522 decodes and converts to UTF8 properly");
+ decode_utf8(q(Dön Armstróng <don@donarmstrong.com>)),"decode_rfc1522 decodes and converts to UTF8 properly");
# 2: test encode
--- /dev/null
+# -*- mode: cperl;-*-
+
+use Test::More tests => 2;
+use Encode qw(decode_utf8);
+
+use_ok('Debbugs::Common');
+is_deeply(Debbugs::Common::encode_utf8_structure(
+ {a => decode_utf8('föö'),
+ b => [map {decode_utf8($_)} qw(blëh bl♥h)],
+ }),
+ {a => 'föö',
+ b => [qw(blëh bl♥h)],
+ },
+ );
use UNIVERSAL;
use Debbugs::MIME qw(decode_rfc1522);
+use Encode qw(encode_utf8);
use_ok('Debbugs::Mail');
END
# 1: test decode
-ok(decode_rfc1522(Debbugs::Mail::encode_headers($test_str)) eq $test_str);
+ok(decode_rfc1522(Debbugs::Mail::encode_headers($test_str)) eq encode_utf8($test_str));
# XXX Figure out a good way to test the send message bit of
# Debbugs::Mail
--- /dev/null
+# -*- mode: cperl;-*-
+# $Id: 05_mail.t,v 1.1 2005/08/17 21:46:17 don Exp $
+
+use Test::More tests => 12;
+
+use warnings;
+use strict;
+
+# Here, we're going to shoot messages through a set of things that can
+# happen.
+
+# First, we're going to send mesages to receive.
+# To do so, we'll first send a message to submit,
+# then send messages to the newly created bugnumber.
+
+use IO::File;
+use File::Temp qw(tempdir);
+use Cwd qw(getcwd);
+use Debbugs::MIME qw(create_mime_message);
+use File::Basename qw(dirname basename);
+# The test functions are placed here to make things easier
+use lib qw(t/lib);
+use DebbugsTest qw(:all);
+use Data::Dumper;
+use Encode qw(decode encode decode_utf8);
+
+# HTTP::Server:::Simple defines a SIG{CHLD} handler that breaks system; undef it here.
+$SIG{CHLD} = sub {};
+my %config;
+eval {
+ %config = create_debbugs_configuration(debug => exists $ENV{DEBUG}?$ENV{DEBUG}:0);
+};
+if ($@) {
+ BAIL_OUT($@);
+}
+
+my $sendmail_dir = $config{sendmail_dir};
+my $spool_dir = $config{spool_dir};
+my $config_dir = $config{config_dir};
+
+END{
+ if ($ENV{DEBUG}) {
+ diag("spool_dir: $spool_dir\n");
+ diag("config_dir: $config_dir\n");
+ diag("sendmail_dir: $sendmail_dir\n");
+ }
+}
+
+# We're going to use create mime message to create these messages, and
+# then just send them to receive.
+
+send_message(to=>'submit@bugs.something',
+ headers => [To => 'submit@bugs.something',
+ From => 'foo@bugs.something',
+ Subject => 'Submiting a bug',
+ ],
+ body => <<EOF,attachments => [{Type=>"text/plain",Charset=>"utf-8",Data=><<EOF2}]) or fail('Unable to send message');
+Package: foo
+Severity: normal
+
+This is a silly bug
+EOF
+This is the silly bug's test ütff8 attachment.
+EOF2
+
+
+
+# now we check to see that we have a bug, and nextnumber has been incremented
+ok(-e "$spool_dir/db-h/01/1.log",'log file created');
+ok(-e "$spool_dir/db-h/01/1.summary",'sumary file created');
+ok(-e "$spool_dir/db-h/01/1.status",'status file created');
+ok(-e "$spool_dir/db-h/01/1.report",'report file created');
+ok(system('sh','-c','[ $(grep "attachment." '.$spool_dir.'/db-h/01/1.log|grep -v "ütff8"|wc -l) -eq 0 ]') == 0,
+ 'Everything attachment is escaped properly');
+
+# next, we check to see that (at least) the proper messages have been
+# sent out. 1) ack to submitter 2) mail to maintainer
+
+# This keeps track of the previous size of the sendmail directory
+my $SD_SIZE = 0;
+$SD_SIZE =
+ num_messages_sent($SD_SIZE,2,
+ $sendmail_dir,
+ 'submit messages appear to have been sent out properly',
+ );
+
+
+# now send a message to the bug
+
+send_message(to => '1@bugs.something',
+ headers => [To => '1@bugs.something',
+ From => 'foo@bugs.something',
+ Subject => 'Sending a message to a bug',
+ ],
+ body => <<EOF) or fail('sending message to 1@bugs.someting failed');
+Package: foo
+Severity: normal
+
+This is a silly bug
+EOF
+
+$SD_SIZE =
+ num_messages_sent($SD_SIZE,2,
+ $sendmail_dir,
+ '1@bugs.something messages appear to have been sent out properly');
+
+# just check to see that control doesn't explode
+send_message(to => 'control@bugs.something',
+ headers => [To => 'control@bugs.something',
+ From => 'foo@bugs.something',
+ Subject => 'Munging a bug',
+ ],
+ body => <<EOF) or fail 'message to control@bugs.something failed';
+severity 1 wishlist
+retitle 1 ütff8 title encoding test
+thanks
+EOF
+
+$SD_SIZE =
+ num_messages_sent($SD_SIZE,1,
+ $sendmail_dir,
+ 'control@bugs.something messages appear to have been sent out properly');
+# now we need to check to make sure the control message was processed without errors
+ok(system('sh','-c','find '.$sendmail_dir.q( -type f | xargs grep -q "Subject: Processed: Munging a bug")) == 0,
+ 'control@bugs.something message was parsed without errors');
+# now we need to check to make sure that the control message actually did anything
+# This is an eval because $ENV{DEBBUGS_CONFIG_FILE} isn't set at BEGIN{} time
+eval "use Debbugs::Status qw(read_bug writebug);";
+my $status = read_bug(bug=>1);
+ok($status->{subject} eq decode_utf8('ütff8 title encoding test'),'bug 1 retitled');
+ok($status->{severity} eq 'wishlist','bug 1 wishlisted');
+ok(system('sh','-c','[ $(egrep "retitle.*encoding test" '.$spool_dir.'/db-h/01/1.log|grep -v "=C3=BCt=EF=AC=808"|wc -l) -eq 0 ]') == 0,
+ 'Control messages escaped properly');
+
},
body => {type => SCALAR,
},
+ attachments => {type => ARRAYREF,
+ default => [],
+ },
run_processall =>{type => BOOLEAN,
default => 1,
},
my $pid = open3($wfd,$rfd,$rfd,'scripts/receive')
or die "Unable to start receive: $!";
print {$wfd} create_mime_message($param{headers},
- $param{body}) or die "Unable to to print to receive";
+ $param{body},
+ $param{attachments}) or
+ die "Unable to to print to receive";
close($wfd) or die "Unable to close receive";
my $err = $? >> 8;
my $childpid = waitpid($pid,0);
projects / debbugs.git / commitdiff