X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=Debbugs%2FMail.pm;h=e4c8bf7da825e53ce64b3f0849079237e07745fa;hb=466f7faff129a5699c7674f59900a92aa256175d;hp=a19399dff5434ac735643df06fd1b1d32e345e49;hpb=25062eec3c5e641b8357fe91add750f8266afe00;p=debbugs.git

diff --git a/Debbugs/Mail.pm b/Debbugs/Mail.pm
index a19399d..e4c8bf7 100644
--- a/Debbugs/Mail.pm
+++ b/Debbugs/Mail.pm
@@ -39,24 +39,33 @@ END
 use warnings;
 use strict;
 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
-use base qw(Exporter);
+use Exporter qw(import);
 
 use IPC::Open3;
 use POSIX qw(:sys_wait_h strftime);
-use Time::HiRes qw(usleep);
+use Time::HiRes qw(usleep gettimeofday);
 use Mail::Address ();
 use Debbugs::MIME qw(encode_rfc1522);
 use Debbugs::Config qw(:config);
 use Params::Validate qw(:types validate_with);
+use Encode qw(encode is_utf8);
+use Debbugs::UTF8 qw(encode_utf8_safely convert_to_utf8);
+
+use Debbugs::Packages;
 
 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 rfc822_date);
+     %EXPORT_TAGS = (addresses => [qw(get_addresses)],
+		     misc      => [qw(rfc822_date)],
+		     mail      => [qw(send_mail_message encode_headers default_headers)],
+                     reply     => [qw(reply_headers)],
+		    );
+     @EXPORT_OK = ();
+     Exporter::export_ok_tags(keys %EXPORT_TAGS);
      $EXPORT_TAGS{all} = [@EXPORT_OK];
-
 }
 
 # We set this here so it can be overridden for testing purposes
@@ -77,6 +86,209 @@ sub get_addresses {
 }
 
 
+=head2 default_headers
+
+      my @head = default_headers(queue_file => 'foo',
+                                 data       => $data,
+                                 msgid      => $header{'message-id'},
+                                 msgtype    => 'error',
+                                 headers    => [...],
+                                );
+      create_mime_message(\@headers,
+                         ...
+                         );
+
+This function is generally called to generate the headers for
+create_mime_message (and anything else that needs a set of default
+headers.)
+
+In list context, returns an array of headers. In scalar context,
+returns headers for shoving in a mail message after encoding using
+encode_headers.
+
+=head3 options
+
+=over
+
+=item queue_file -- the queue file which will generate this set of
+headers (refered to as $nn in lots of the code)
+
+=item data -- the data of the bug which this message involves; can be
+undefined if there is no bug involved.
+
+=item msgid -- the Message-ID: of the message which will generate this
+set of headers
+
+=item msgtype -- the type of message that this is.
+
+=item pr_msg -- the pr message field
+
+=item headers -- a set of headers which will override the default
+headers; these headers will be passed through (and may be reordered.)
+If a particular header is undef, it overrides the default, but isn't
+passed through.
+
+=back
+
+=head3 default headers
+
+=over
+
+=item X-Loop -- set to the maintainer e-mail
+
+=item From -- set to the maintainer e-mail
+
+=item To -- set to Unknown recipients
+
+=item Subject -- set to Unknown subject
+
+=item Message-ID -- set appropriately (see code)
+
+=item Precedence -- set to bulk
+
+=item References -- set to the full set of message ids that are known
+(from data and the msgid option)
+
+=item In-Reply-To -- set to msg id or the msgid from data
+
+=item X-Project-PR-Message -- set to pr_msg with the bug number appended
+
+=item X-Project-PR-Package -- set to the package of the bug
+
+=item X-Project-PR-Keywords -- set to the keywords of the bug
+
+=item X-Project-PR-Source -- set to the source of the bug
+
+=back
+
+=cut
+
+sub default_headers {
+    my %param = validate_with(params => \@_,
+			      spec   => {queue_file => {type => SCALAR|UNDEF,
+							optional => 1,
+						       },
+					 data       => {type => HASHREF,
+							optional => 1,
+						       },
+					 msgid      => {type => SCALAR|UNDEF,
+							optional => 1,
+						       },
+					 msgtype    => {type => SCALAR|UNDEF,
+							default => 'misc',
+						       },
+					 pr_msg     => {type => SCALAR|UNDEF,
+							default => 'misc',
+						       },
+					 headers    => {type => ARRAYREF,
+							default => [],
+						       },
+					},
+			     );
+    my @header_order = (qw(X-Loop From To subject),
+			qw(Message-ID In-Reply-To References));
+    # handle various things being undefined
+    if (not exists $param{queue_file} or
+	not defined $param{queue_file}) {
+	$param{queue_file} = join('',gettimeofday())
+    }
+    for (qw(msgtype pr_msg)) {
+	if (not exists $param{$_} or
+	    not defined $param{$_}) {
+	    $param{$_} = 'misc';
+	}
+    }
+    my %header_order;
+    @header_order{map {lc $_} @header_order} = 0..$#header_order;
+    my %set_headers;
+    my @ordered_headers;
+    my @temp = @{$param{headers}};
+    my @other_headers;
+    while (my ($header,$value) = splice @temp,0,2) {
+	if (exists $header_order{lc($header)}) {
+	    push @{$ordered_headers[$header_order{lc($header)}]},
+		($header,$value);
+	}
+	else {
+	    push @other_headers,($header,$value);
+	}
+	$set_headers{lc($header)} = 1;
+    }
+
+    # calculate our headers
+    my $bug_num = exists $param{data} ? $param{data}{bug_num} : 'x';
+    my $nn = $param{queue_file};
+    # handle the user giving the actual queue filename instead of nn
+    $nn =~ s/^[a-zA-Z]([a-zA-Z])/$1/;
+    $nn = lc($nn);
+    my @msgids;
+    if (exists $param{msgid} and defined $param{msgid}) {
+	push @msgids, $param{msgid}
+    }
+    elsif (exists $param{data} and defined $param{data}{msgid}) {
+	push @msgids, $param{data}{msgid}
+    }
+    my %default_header;
+    $default_header{'X-Loop'} = $config{maintainer_email};
+    $default_header{From}     = "$config{maintainer_email} ($config{project} $config{ubug} Tracking System)";
+    $default_header{To}       = "Unknown recipients";
+    $default_header{Subject}  = "Unknown subject";
+    $default_header{'Message-ID'} = "<handler.${bug_num}.${nn}.$param{msgtype}\@$config{email_domain}>";
+    if (@msgids) {
+	$default_header{'In-Reply-To'} = $msgids[0];
+	$default_header{'References'} = join(' ',@msgids);
+    }
+    $default_header{Precedence} = 'bulk';
+    $default_header{"X-$config{project}-PR-Message"} = $param{pr_msg} . (exists $param{data} ? ' '.$param{data}{bug_num}:'');
+    $default_header{Date} = rfc822_date();
+    if (exists $param{data}) {
+	if (defined $param{data}{keywords}) {
+	    $default_header{"X-$config{project}-PR-Keywords"} = $param{data}{keywords};
+	}
+	if (defined $param{data}{package}) {
+	    $default_header{"X-$config{project}-PR-Package"} = $param{data}{package};
+	    if ($param{data}{package} =~ /^src:(.+)$/) {
+		$default_header{"X-$config{project}-PR-Source"} = $1;
+	    }
+	    else {
+		my $pkg_src = Debbugs::Packages::getpkgsrc();
+		$default_header{"X-$config{project}-PR-Source"} = $pkg_src->{$param{data}{package}};
+	    }
+	}
+    }
+    for my $header (sort keys %default_header) {
+	next if $set_headers{lc($header)};
+	if (exists $header_order{lc($header)}) {
+	    push @{$ordered_headers[$header_order{lc($header)}]},
+		($header,$default_header{$header});
+	}
+	else {
+	    push @other_headers,($header,$default_header{$header});
+	}
+    }
+    my @headers;
+    for my $hdr1 (@ordered_headers) {
+	next if not defined $hdr1;
+	my @temp = @{$hdr1};
+	while (my ($header,$value) = splice @temp,0,2) {
+	    next if not defined $value;
+	    push @headers,($header,$value);
+	}
+    }
+    push @headers,@other_headers;
+    if (wantarray) {
+	return @headers;
+    }
+    else {
+	my $headers = '';
+	while (my ($header,$value) = splice @headers,0,2) {
+	    $headers .= "${header}: $value\n";
+	}
+	return $headers;
+    }
+}
+
+
 
 =head2 send_mail_message
 
@@ -111,7 +323,7 @@ using warn.
 sub send_mail_message{
      my %param = validate_with(params => \@_,
 			       spec  => {sendmail_arguments => {type => ARRAYREF,
-								default => [qw(-odq -oem -oi)],
+								default => $config{sendmail_arguments},
 							       },
 					 parse_for_recipients => {type => BOOLEAN,
 								  default => 0,
@@ -122,15 +334,18 @@ sub send_mail_message{
 					 message              => {type => SCALAR,
 								 },
 					 envelope_from        => {type => SCALAR,
-								  optional => 1,
+								  default => $config{envelope_from},
 								 },
 					 recipients           => {type => ARRAYREF|UNDEF,
 								  optional => 1,
 								 },
 					},
 			      );
-     my @sendmail_arguments = qw(-odq -oem -oi);
-     push @sendmail_arguments, '-f', $param{envelope_from} if exists $param{envelope_from};
+     my @sendmail_arguments = @{$param{sendmail_arguments}};
+     push @sendmail_arguments, '-f', $param{envelope_from} if
+	 exists $param{envelope_from} and
+	 defined $param{envelope_from} and
+	 length $param{envelope_from};
 
      my @recipients;
      @recipients = @{$param{recipients}} if defined $param{recipients} and
@@ -188,7 +403,7 @@ sub encode_headers{
 
      my ($header,$body) = split /\n\n/, $message, 2;
      $header = encode_rfc1522($header);
-     return $header . qq(\n\n). $body;
+     return $header . qq(\n\n). encode_utf8_safely($body);
 }
 
 =head2 rfc822_date
@@ -203,6 +418,82 @@ sub rfc822_date{
      return scalar strftime "%a, %d %h %Y %T +0000", gmtime;
 }
 
+=head2 reply_headers
+
+     reply_headers(MIME::Parser->new()->parse_data(\$data));
+
+Generates suggested headers and a body for replies. Primarily useful
+for use in RFC2368 mailto: entries.
+
+=cut
+
+sub reply_headers{
+    my ($entity) = @_;
+
+    my $head = $entity->head;
+    # build reply link
+    my %r_l;
+    $r_l{subject} = $head->get('Subject');
+    $r_l{subject} //= 'Your mail';
+    $r_l{subject} = 'Re: '. $r_l{subject} unless $r_l{subject} =~ /(?:^|\s)Re:\s+/;
+    $r_l{subject} =~ s/(?:^\s*|\s*$)//g;
+    $r_l{'In-Reply-To'} = $head->get('Message-Id');
+    $r_l{'In-Reply-To'} =~ s/(?:^\s*|\s*$)//g if defined $r_l{'In-Reply-To'};
+    delete $r_l{'In-Reply-To'} unless defined $r_l{'In-Reply-To'};
+    $r_l{References} = ($head->get('References')//''). ' '.($head->get('Message-Id')//'');
+    $r_l{References} =~ s/(?:^\s*|\s*$)//g;
+    my $date = $head->get('Date') // 'some date';
+    $date =~ s/(?:^\s*|\s*$)//g;
+    my $who = $head->get('From') // $head->get('Reply-To') // 'someone';
+    $who =~ s/(?:^\s*|\s*$)//g;
+
+    my $body = "On $date $who wrote:\n";
+    my $i = 60;
+    my $b_h;
+    # Default to UTF-8.
+    my $charset="utf-8";
+    ## find the first part which has a defined body handle and appears
+    ## to be text
+    if (defined $entity->bodyhandle) {
+	my $this_charset =
+	    $entity->head->mime_attr("content-type.charset");
+	$charset = $this_charset if
+	    defined $this_charset and
+	    length $this_charset;
+        $b_h = $entity->bodyhandle;
+    } elsif ($entity->parts) {
+        my @parts = $entity->parts;
+        while (defined(my $part = shift @parts)) {
+            if ($part->parts) {
+                push @parts,$part->parts;
+            }
+            if (defined $part->bodyhandle and
+                $part->effective_type =~ /text/) {
+		my $this_charset =
+		    $part->head->mime_attr("content-type.charset");
+		$charset =  $this_charset if
+		    defined $this_charset and
+		    length $this_charset;
+                $b_h = $part->bodyhandle;
+                last;
+            }
+        }
+    }
+    if (defined $b_h) {
+        eval {
+            my $IO = $b_h->open("r");
+            while (defined($_ = $IO->getline)) {
+                $i--;
+                last if $i < 0;
+                $body .= '> '. convert_to_utf8($_,$charset);
+            }
+            $IO->close();
+        };
+    }
+    $r_l{body} = $body;
+    return \%r_l;
+}
+
 =head1 PRIVATE FUNCTIONS
 
 =head2 _send_message