--- /dev/null
+# $Id: Mail.pm,v 1.1 2005/08/17 21:46:16 don Exp $
+
+package Debbugs::Mail;
+
+=head1 NAME
+
+Debbugs::Mail -- Outgoing Mail Handling
+
+=head1 SYNOPSIS
+
+use Debbugs::Mail qw(send_mail_message get_addresses);
+
+my @addresses = get_addresses('blah blah blah foo@bar.com')
+send_mail_message(message => <<END, recipients=>[@addresses]);
+To: $addresses[0]
+Subject: Testing
+
+Testing 1 2 3
+END
+
+=head1 EXPORT TAGS
+
+=over
+
+=item :all -- all functions that can be exported
+
+=back
+
+=head1 FUNCTIONS
+
+
+=cut
+
+use warnings;
+use strict;
+use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
+use base qw(Exporter);
+
+use IPC::Open3;
+use POSIX ":sys_wait_h";
+use Time::HiRes qw(usleep);
+use Mail::Address ();
+use Debbugs::MIME qw(encode_rfc1522);
+
+BEGIN{
+ ($VERSION) = q$Revision: 1.1 $ =~ /^Revision:\s+([^\s+])/;
+ $DEBUG = 0 unless defined $DEBUG;
+
+ @EXPORT = ();
+ @EXPORT_OK = qw(send_mail_message get_addresses encode_headers);
+ $EXPORT_TAGS{all} = [@EXPORT_OK];
+
+}
+
+=head2 get_addresses
+
+ my @addresses = get_addresses('don@debian.org blars@debian.org
+ kamion@debian.org ajt@debian.org');
+
+Given a string containing some e-mail addresses, parses the string
+using Mail::Address->parse and returns a list of the addresses.
+
+=cut
+
+sub get_addresses {
+ return map { $_->address() } map { Mail::Address->parse($_) } @_;
+}
+
+
+
+=head2 send_mail_message
+
+ send_mail_message(message => $message,
+ recipients => [@recipients],
+ envelope_from => 'don@debian.org',
+ );
+
+
+=over
+
+=item message -- message to send out
+
+=item recipients -- recipients to send the message to. If undefed or
+an empty arrayref, will use '-t' to parse the message for recipients.
+
+=item envelope_from -- envelope_from for outgoing messages
+
+=item encode_headers -- encode headers using RFC1522 (default)
+
+=item parse_for_recipients -- use -t to parse the message for
+recipients in addition to those specified. [Can be used to set Bcc
+recipients, for example.]
+
+=back
+
+Returns true on success, false on failures. All errors are indicated
+using warn.
+
+=cut
+
+sub send_mail_message{
+ die "send_mail_message requires an even number of arguments" if @_ % 2;
+ # It would be better to use Param::Validate instead...
+ my %param = @_;
+
+ die "send_mail_message requires a message" if not defined $param{message};
+
+ my @sendmail_arguments = qw(-odq -oem -oi);
+ push @sendmail_arguments, '-f', $param{envelope_from} if exists $param{envelope_from};
+
+ my @recipients;
+ @recipients = @{$param{recipients}} if defined $param{recipients} and
+ ref($param{recipients}) eq 'ARRAY';
+ # If there are no recipients, use -t to parse the message
+ if (@recipients == 0) {
+ $param{parse_for_recipients} = 1 unless exists $param{parse_for_recipients};
+ }
+ # Encode headers if necessary
+ $param{encode_headers} = 1 if not exists $param{encode_headers};
+ if ($param{encode_headers}) {
+ $param{message} = encode_headers($param{message});
+ }
+
+ # First, try to send the message as is.
+ eval {
+ _send_message($param{message},
+ @sendmail_arguments,
+ $param{parse_for_recipients}?q(-t):(),
+ @recipients);
+ };
+ return 1 unless $@;
+ # If there's only one recipient, there's nothing more we can do,
+ # so bail out.
+ warn $@ and return 0 if $@ and @recipients == 0;
+ # If that fails, try to send the message to each of the
+ # recipients separately. We also send the -t option separately in
+ # case one of the @recipients is ok, but the addresses in the
+ # mail message itself are malformed.
+ my @errors;
+ for my $recipient ($param{parse_for_recipients}?q(-t):(),@recipients) {
+ eval {
+ _send_message($param{message},@sendmail_arguments,$recipient);
+ };
+ push @errors, "Sending to $recipient failed with $@" if $@;
+ }
+ # If it still fails, complain bitterly but don't die.
+ warn join(qq(\n),@errors) and return 0 if @errors;
+ return 1;
+}
+
+=head2 encode_headers
+
+ $message = encode_heeaders($message);
+
+RFC 1522 encodes the headers of a message
+
+=cut
+
+sub encode_headers{
+ my ($message) = @_;
+
+ my ($header,$body) = split /\n\n/, $message, 2;
+ $header = encode_rfc1522($header);
+ return $header . qq(\n\n). $body;
+}
+
+
+=head1 PRIVATE FUNCTIONS
+
+=head2 _send_message
+
+ _send_message($message,@sendmail_args);
+
+Private function that actually calls sendmail with @sendmail_args and
+sends message $message.
+
+dies with errors, so calls to this function in send_mail_message
+should be wrapped in eval.
+
+=cut
+
+sub _send_message{
+ my ($message,@sendmail_args) = @_;
+
+ my ($wfh,$rfh);
+ my $pid = open3($wfh,$rfh,$rfh,'/usr/lib/sendmail',@sendmail_args)
+ or die "Unable to fork off /usr/lib/sendmail: $!";
+ local $SIG{PIPE} = 'IGNORE';
+ eval {
+ print {$wfh} $message or die "Unable to write to /usr/lib/sendmail: $!";
+ close $wfh or die "/usr/lib/sendmail exited with $?";
+ };
+ if ($@) {
+ local $\;
+ # Reap the zombie
+ waitpid($pid,WNOHANG);
+ # This shouldn't block because the pipe closing is the only
+ # way this should be triggered.
+ my $message = <$rfh>;
+ die "$@$message";
+ }
+ # Wait for sendmail to exit for at most 30 seconds.
+ my $loop = 0;
+ while (waitpid($pid, WNOHANG) == 0 or $loop++ >= 600){
+ # sleep for a 20th of a second
+ usleep(50_000);
+ }
+ if ($loop >= 600) {
+ warn "Sendmail didn't exit within 30 seconds";
+ }
+}
+
+
+1;
+
+
+__END__
+
+
+
+
+
+
scripts_in := $(filter-out scripts/config.in scripts/errorlib.in scripts/text.in, $(wildcard scripts/*.in))
htmls_in := $(wildcard html/*.html.in)
cgis := $(wildcard cgi/*.cgi cgi/*.pl)
-perls := $(foreach name,Log MIME Packages Versions,Debbugs/$(name).pm)
+perls := $(foreach name,Log MIME Mail Packages Versions,Debbugs/$(name).pm)
install_exec := install -m755 -p
install_data := install -m644 -p
that look like urls in the html records output by bugreport.cgi.
- Things that look like urls in message bodies are now linked
(closes: #168962)
+ - Add Debbugs::Mail module that has two important functions:
+ send_mail_message and encode_headers. All mail handling in service.in
+ and process.in now uses send_mail_message to send mail messages which
+ tries as hard as possible to send a message; if it fails, only
+ warnings are returned. This fixes bad addresses causing sendmail to
+ exit and destroying the bug log. (closes: #191306)
+ - Add rudimentary Test::More modules for testing Debbugs::Mime and
+ Debbugs::Mail. These are currently not called as part of the build
+ process.
-- Colin Watson <cjwatson@debian.org> Fri, 20 Jun 2003 18:57:25 +0100
#!/usr/bin/perl
-# $Id: process.in,v 1.101 2005/07/30 03:55:01 don Exp $
+# $Id: process.in,v 1.102 2005/08/17 21:46:16 don Exp $
#
# Usage: process nn
# Temps: incoming/Pnn
use IO::File;
use MIME::Parser;
-use Debbugs::MIME qw(decode_rfc1522 encode_rfc1522);
+use Debbugs::MIME qw(decode_rfc1522);
+use Debbugs::Mail qw(send_mail_message encode_headers);
$config_path = '/etc/debbugs';
$lib_path = '/usr/lib/debbugs';
# The original message received is written out in appendlog, so
# before writing out the other messages we've sent out, we need to
# RFC1522 encode the header.
- my ($header,$body) = split /\n\n/, $msg, 2;
- $header = encode_rfc1522($header);
- $msg = $header . qq(\n\n). $body;
+ $msg = encode_headers($msg);
my $hash = get_hashname($ref);
#save email to the log
push @$recips, @$bcc;
}
- send_mail_message($msg,$recips);
+ send_mail_message(message => $msg,
+ # Because we encode the headers above, we do not want to encode them here
+ encode_headers => 0,
+ recipients => $recips);
}
sub checkmaintainers {
}
}
-=head2 send_mail_message
-
- send_mail_message($message,[@recipients],$envelope_from)
-
-Sends a mail message out to a set of recepients with envelope sender
-$envelope_from; if $envelope_from is not set, defaults to
-$gMaintainerEmail.
-
-=cut
-
-sub send_mail_message{
- my ($message,$recipients,$envelope_from) = @_;
-
- # Default to $gMaintainerEmail
- $envelope_from ||= $gMaintainerEmail;
-
- print DEBUG "sending mail to ".join(', ',@$recipients)." with -f $envelope_from";
- local $_ = '';
- $SIG{'CHLD'}='chldhandle';
- #print DEBUG "mailing sigchild set up<\n";
- our $chldexit = 'no';
- our $c= open(U,"-|");
- #print DEBUG "mailing opened pipe fork<\n";
- defined($c) || die $!;
- #print DEBUG "mailing opened pipe fork ok $c<\n";
- if (!$c) { # ie, we are in the child process
- #print DEBUG "mailing child<\n";
- unless (open(STDERR,">&STDOUT")) {
- #print DEBUG "mailing child opened stderr<\n";
- print STDOUT "redirect stderr: $!\n";
- #print DEBUG "mailing child opened stderr fail<\n";
- exit 1;
- #print DEBUG "mailing child opened stderr fail exit !?<\n";
- }
- #print DEBUG "mailing child opened stderr ok<\n";
- $c= open(D,"|-");
- #print DEBUG "mailing child forked again<\n";
- defined($c) || die $!;
- #print DEBUG "mailing child forked again ok $c<\n";
- if (!$c) { # ie, we are the child process
- #print DEBUG "mailing grandchild<\n";
- exec '/usr/lib/sendmail', (defined $envelope_from?'-f'.$envelope_from:''),'-odq','-oem','-oi',
- @{$recipients};
- #print DEBUG "mailing grandchild exec failed<\n";
- die $!;
- #print DEBUG "mailing grandchild died !?<\n";
- }
- #print DEBUG "mailing child not grandchild<\n";
- print(D $message) || die $!;
- #print DEBUG "mailing child printed msg<\n";
- close(D);
- #print DEBUG "mailing child closed pipe<\n";
- die "\n*** command returned exit status $?\n" if $?;
- #print DEBUG "mailing child exit status ok<\n";
- exit 0;
- #print DEBUG "mailing child exited ?!<\n";
- }
- #print DEBUG "mailing parent<\n";
- $results='';
- #print DEBUG "mailing parent results emptied<\n";
- while( $chldexit eq 'no' ) { $results.= $_; }
- #print DEBUG "mailing parent results read >$results<\n";
- close(U);
- #print DEBUG "mailing parent results closed<\n";
- $results.= "\n*** child returned exit status $?\n" if $?;
- #print DEBUG "mailing parent exit status ok<\n";
- $SIG{'CHLD'}='DEFAULT';
- #print DEBUG "mailing parent sigchild default<\n";
- if (length($results)) { &quit("running sendmail: $results"); }
- #print DEBUG "mailing parent results ok<\n";
-
-
-}
-
=head2 bug_list_forward
bug_list_forward($spool_filename) if $codeletter eq 'L';
$bug_address =~ s/\@.+//;
print DEBUG "Sending message to bugs=$bug_address\@$gListDomain\n";
print DEBUG $header.qq(\n\n).$body;
- send_mail_message($header.qq(\n\n).$body,
- ["bugs=$bug_address\@$gListDomain"],
- $envelope_from,
+ send_mail_message(message => $header.qq(\n\n).$body,
+ recipients => ["bugs=$bug_address\@$gListDomain"],
+ envelope_from => $envelope_from,
+ encode_headers => 0,
);
unlink("incoming/P$bug_fn") || &quit("unlinking incoming/P$bug_fn: $!");
exit 0;
#!/usr/bin/perl
-# $Id: service.in,v 1.111 2005/07/30 03:22:36 don Exp $
+# $Id: service.in,v 1.112 2005/08/17 21:46:17 don Exp $
#
# Usage: service <code>.nn
# Temps: incoming/P<code>.nn
use File::Copy;
use MIME::Parser;
use Debbugs::MIME qw(decode_rfc1522 encode_rfc1522);
+use Debbugs::Mail qw(send_mail_message);
$config_path = '/etc/debbugs';
$lib_path = '/usr/lib/debbugs';
sub sendmailmessage {
local ($message,@recips) = @_;
$message = "X-Loop: $gMaintainerEmail\n" . $message;
- # The original message received is written out above, so before
- # writing out the other messages we've sent out, we need to
- # RFC1522 encode the header.
- my ($header,$body) = split /\n\n/, $message, 2;
- $header = encode_rfc1522($header);
- $message = $header . qq(\n\n). $body;
-
- print "mailing to >@recips<\n" if $debug;
- $c= open(D,"|-");
- defined($c) || &quit("mailing forking for sendmail: $!");
- if (!$c) { # ie, we are the child process
- exec '/usr/lib/sendmail','-f'."$gMaintainerEmail",'-odb','-oem','-oi',get_addresses(@recips);
- die $!;
- }
- print(D $message) || &quit("writing to sendmail process: $!");
- $!=0; close(D); $? && &quit("sendmail gave exit status $? ($!)");
+ send_mail_message(message => $message,
+ recipients => \@recips,
+ );
$midix++;
}
--- /dev/null
+# -*- mode: cperl;-*-
+# $Id: 01_mime.t,v 1.1 2005/08/17 21:46:17 don Exp $
+
+use Test::More tests => 3;
+
+use warnings;
+use strict;
+
+use utf8;
+
+use_ok('Debbugs::MIME');
+
+# encode_headers testing
+
+my $test_str = <<'END';
+Döñ Ärḿßtrøñĝ <don@donarmstrong.com>
+END
+
+# 1: test decode
+ok(Debbugs::MIME::decode_rfc1522(q(=?iso-8859-1?Q?D=F6n_Armstr=F3ng?= <don@donarmstrong.com>)) eq
+ q(Dön Armstróng <don@donarmstrong.com>),"decode_rfc1522 decodes and converts to UTF8 properly");
+
+
+# 2: test encode
+ok(Debbugs::MIME::decode_rfc1522(Debbugs::MIME::encode_rfc1522($test_str)) eq $test_str,
+ "encode_rfc1522 encodes strings that decode_rfc1522 can decode");
+
+# XXX figure out how to test parse
--- /dev/null
+# -*- mode: cperl;-*-
+# $Id: 05_mail.t,v 1.1 2005/08/17 21:46:17 don Exp $
+
+use Test::More tests => 2;
+
+use warnings;
+use strict;
+
+use utf8;
+
+use UNIVERSAL;
+
+use Debbugs::MIME qw(decode_rfc1522);
+
+use_ok('Debbugs::Mail');
+
+# encode_headers testing
+
+my $test_str = <<'END';
+To: Döñ Ärḿßtrøñĝ <don@donarmstrong.com>
+Subject: testing
+
+blah blah blah
+END
+
+# 1: test decode
+ok(decode_rfc1522(Debbugs::Mail::encode_headers($test_str)) eq $test_str);
+
+# XXX Figure out a good way to test the send message bit of
+# Debbugs::Mail
projects / debbugs.git / commitdiff