1 # This module is part of debbugs, and is released
2 # under the terms of the GPL version 2, or any later version. See the
3 # file README and COPYING for more information.
5 # [Other people have contributed to this file; their copyrights should
7 # Copyright 2008 by Don Armstrong <don@donarmstrong.com>.
10 package Debbugs::CGI::Bugreport;
14 Debbugs::CGI::Bugreport -- specific routines for the bugreport cgi script
30 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
31 use base qw(Exporter);
34 use Params::Validate qw(validate_with :types);
35 use Debbugs::MIME qw(convert_to_utf8 decode_rfc1522 create_mime_message);
36 use Debbugs::CGI qw(:url :html :util);
37 use POSIX qw(strftime);
40 ($VERSION) = q$Revision: 494 $ =~ /^Revision:\s+([^\s+])/;
41 $DEBUG = 0 unless defined $DEBUG;
45 @EXPORT_OK = (qw(display_entities handle_record handle_email_message));
46 Exporter::export_ok_tags(keys %EXPORT_TAGS);
47 $EXPORT_TAGS{all} = [@EXPORT_OK];
54 display_entity(entity => $entity,
58 attachments => \@attachments,
64 =item entity -- MIME::Parser entity
66 =item bug_num -- Bug number
68 =item outer -- Whether this is the outer entity; defaults to 1
70 =item msg_num -- message number in the log
72 =item attachments -- arrayref of attachments
74 =item output -- scalar reference for output
81 my %param = validate_with(params => \@_,
82 spec => {entity => {type => OBJECT,
84 bug_num => {type => SCALAR,
87 outer => {type => BOOLEAN,
90 msg_num => {type => SCALAR,
92 attachments => {type => ARRAYREF,
95 output => {type => SCALARREF|HANDLE,
98 terse => {type => BOOLEAN,
101 msg => {type => SCALAR,
104 att => {type => SCALAR,
107 trim_headers => {type => BOOLEAN,
113 my $entity = $param{entity};
114 my $ref = $param{bug_num};
115 my $top = $param{outer};
116 my $xmessage = $param{msg_num};
117 if (defined ref($param{output}) and
118 ref($param{output}) eq 'SCALAR' and
119 not UNIVERSAL::isa($param{output},'GLOB')) {
120 $param{output} = IO::Scalar->new($param{output});
122 my $attachments = $param{attachments};
124 my $head = $entity->head;
125 my $disposition = $head->mime_attr('content-disposition');
126 $disposition = 'inline' if not defined $disposition or $disposition eq '';
127 my $type = $entity->effective_type;
128 my $filename = $entity->head->recommended_filename;
129 $filename = '' unless defined $filename;
130 $filename = decode_rfc1522($filename);
132 if ($top and not $param{terse}) {
133 my $header = $entity->head;
134 print {$param{output}} "<pre class=\"headers\">\n";
135 if ($param{trim_headers}) {
137 foreach (qw(From To Cc Subject Date)) {
138 my $head_field = $head->get($_);
139 next unless defined $head_field and $head_field ne '';
140 push @headers, qq(<b>$_:</b> ) . html_escape(decode_rfc1522($head_field));
142 print {$param{output}} join(qq(), @headers);
144 print {$param{output}} html_escape(decode_rfc1522($entity->head->stringify));
146 print {$param{output}} "</pre>\n";
149 unless (($top and $type =~ m[^text(?:/plain)?(?:;|$)]) or
150 ($type =~ m[^multipart/])) {
151 push @$attachments, $entity;
152 my @dlargs = ($ref, msg=>$xmessage, att=>$#$attachments);
153 push @dlargs, (filename=>$filename) if $filename ne '';
154 my $printname = $filename;
155 $printname = 'Message part ' . ($#$attachments + 1) if $filename eq '';
156 print {$param{output}} '<pre class="mime">[<a href="' . html_escape(bug_url(@dlargs)) . qq{">$printname</a> } .
157 "($type, $disposition)]</pre>\n";
159 if (exists $param{msg} and exists $param{att} and
160 $param{att} == $#$attachments) {
161 my $head = $entity->head;
162 chomp(my $type = $entity->effective_type);
163 my $body = $entity->stringify_body;
164 print {$param{output}} "Content-Type: $type";
165 my ($charset) = $head->get('Content-Type:') =~ m/charset\s*=\s*\"?([\w-]+)\"?/i;
166 print {$param{output}} qq(; charset="$charset") if defined $charset;
167 print {$param{output}}"\n";
168 if ($filename ne '') {
172 print {$param{output}} qq{Content-Disposition: inline; filename="$qf"\n};
174 print {$param{output}} "\n";
175 my $decoder = MIME::Decoder->new($head->mime_encoding);
176 $decoder->decode(new IO::Scalar(\$body), \*STDOUT);
181 return if not $top and $disposition eq 'attachment' and not defined($param{att});
182 return unless ($type =~ m[^text/?] and
183 $type !~ m[^text/(?:html|enriched)(?:;|$)]) or
184 $type =~ m[^application/pgp(?:;|$)] or
187 if ($entity->is_multipart) {
188 my @parts = $entity->parts;
189 foreach my $part (@parts) {
190 display_entity(entity => $part,
193 msg_num => $xmessage,
194 output => $param{output},
195 attachments => $attachments,
196 terse => $param{terse},
197 exists $param{msg}?(msg=>$param{msg}):(),
198 exists $param{attachment}?(attachment=>$param{attachment}):(),
200 print {$param{output}} "\n";
202 } elsif ($entity->parts) {
203 # We must be dealing with a nested message.
204 print {$param{output}} "<blockquote>\n";
205 my @parts = $entity->parts;
206 foreach my $part (@parts) {
207 display_entity(entity => $part,
210 msg_num => $xmessage,
211 ouput => $param{output},
212 attachments => $attachments,
213 terse => $param{terse},
214 exists $param{msg}?(msg=>$param{msg}):(),
215 exists $param{attachment}?(attachment=>$param{attachment}):(),
217 print {$param{output}} "\n";
219 print {$param{output}} "</blockquote>\n";
220 } elsif (not $param{terse}) {
221 my $content_type = $entity->head->get('Content-Type:') || "text/html";
222 my ($charset) = $content_type =~ m/charset\s*=\s*\"?([\w-]+)\"?/i;
223 my $body = $entity->bodyhandle->as_string;
224 $body = convert_to_utf8($body,$charset) if defined $charset;
225 $body = html_escape($body);
226 # Attempt to deal with format=flowed
227 if ($content_type =~ m/format\s*=\s*\"?flowed\"?/i) {
228 $body =~ s{^\ }{}mgo;
229 # we ignore the other things that you can do with
230 # flowed e-mails cause they don't really matter.
233 # We don't html escape here because we escape above;
234 # wierd terminators are because of that
235 $body =~ s{((?:ftp|http|https|svn|ftps|rsync)://[\S~-]+?/?) # Url
236 ((?:\>\;)?[)]?(?:'|\&\#39\;)?[:.\,]?(?:\s|$)) # terminators
237 }{<a href=\"$1\">$1</a>$2}gox;
238 # Add links to bug closures
239 $body =~ s[(closes:\s*(?:bug)?\#?\s?\d+(?:,?\s*(?:bug)?\#?\s?\d+)*)]
243 html_escape(bug_url($1)).
247 print {$param{output}} qq(<pre class="message">$body</pre>\n);
252 =head2 handle_email_message
254 handle_email_message($record->{text},
256 msg_num => $msg_number,
259 Returns a decoded e-mail message and displays entities/attachments as
265 sub handle_email_message{
266 my ($email,%param) = @_;
269 my $parser = new MIME::Parser;
270 # Because we are using memory, not tempfiles, there's no need to
271 # clean up here like in Debbugs::MIME
272 $parser->tmp_to_core(1);
273 $parser->output_to_core(1);
274 my $entity = $parser->parse_data( $email);
275 my @attachments = ();
276 display_entity(entity => $entity,
277 bug_num => $param{ref},
279 msg_num => $param{msg_num},
281 attachments => \@attachments,
282 terse => $param{terse},
283 exists $param{msg}?(msg=>$param{msg}):(),
284 exists $param{att}?(attachment=>$param{att}):(),
292 push @log, handle_record($record,$ref,$msg_num);
294 Deals with a record in a bug log as returned by
295 L<Debbugs::Log::read_log_records>; returns the log information that
296 should be output to the browser.
301 my ($record,$bug_number,$msg_number,$seen_msg_ids) = @_;
304 local $_ = $record->{type};
306 my ($time) = $record->{text} =~ /<!--\s+time:(\d+)\s+-->/;
307 my $class = $record->{text} =~ /^<strong>(?:Acknowledgement|Reply|Information|Report|Notification)/ ? 'infmessage':'msgreceived';
308 $output .= decode_rfc1522($record->{text});
309 # Link to forwarded http:// urls in the midst of the report
310 # (even though these links already exist at the top)
311 $output =~ s,((?:ftp|http|https)://[\S~-]+?/?)([\)\'\:\.\,]?(?:\s|\.<|$)),<a href=\"$1\">$1</a>$2,go;
312 # Add links to the cloned bugs
313 $output =~ s{(Bug )(\d+)( cloned as bugs? )(\d+)(?:\-(\d+)|)}{$1.bug_links(bug=>$2).$3.bug_links(bug=>[$4..$5])}eo;
314 # Add links to merged bugs
315 $output =~ s{(?<=Merged )([\d\s]+)(?=\.)}{join(' ',map {bug_links(bug=>$_)} (split /\s+/, $1))}eo;
316 # Add links to blocked bugs
317 $output =~ s{(?<=Blocking bugs)(?:( of )(\d+))?( (?:added|set to|removed):\s+)([\d\s\,]+)}
318 {(defined $2?$1.bug_links(bug=>$2):'').$3.
319 join(' ',map {bug_links(bug=>$_)} (split /\,?\s+/, $4))}eo;
320 # Add links to reassigned packages
321 $output =~ s{(Bug reassigned from package \`)([^']+?)((?:'|\&\#39;) to \`)([^']+?)((?:'|\&\#39;))}
322 {$1.q(<a href=").html_escape(pkg_url(pkg=>$2)).qq(">$2</a>).$3.q(<a href=").html_escape(pkg_url(pkg=>$4)).qq(">$4</a>).$5}eo;
324 $output .= ' ('.strftime('%a, %d %b %Y %T GMT',gmtime($time)).') ';
326 $output .= '<a href="' . html_escape(bug_url($bug_number, msg => ($msg_number+1))) . '">Full text</a> and <a href="' .
327 html_escape(bug_url($bug_number, msg => ($msg_number+1), mbox => 'yes')) . '">rfc822 format</a> available.';
329 $output = qq(<div class="$class"><hr>\n<a name="$msg_number"></a>\n) . $output . "</div>\n";
332 my ($msg_id) = $record->{text} =~ /^Message-Id:\s+<(.+)>/im;
333 if (defined $msg_id and exists $$seen_msg_ids{$msg_id}) {
336 elsif (defined $msg_id) {
337 $$seen_msg_ids{$msg_id} = 1;
339 $output .= qq(<hr><p class="msgreceived"><a name="$msg_number"></a>\n);
340 $output .= 'View this message in <a href="' . html_escape(bug_url($bug_number, msg=>$msg_number, mbox=>'yes')) . '">rfc822 format</a></p>';
341 $output .= handle_email_message($record->{text},
343 msg_num => $msg_number,
346 elsif (/autocheck/) {
349 elsif (/incoming-recv/) {
350 my ($msg_id) = $record->{text} =~ /^Message-Id:\s+<(.+)>/im;
351 if (defined $msg_id and exists $$seen_msg_ids{$msg_id}) {
354 elsif (defined $msg_id) {
355 $$seen_msg_ids{$msg_id} = 1;
357 # Incomming Mail Message
358 my ($received,$hostname) = $record->{text} =~ m/Received: \(at (\S+)\) by (\S+)\;/;
359 $output .= qq|<hr><p class="msgreceived"><a name="$msg_number"></a><a name="msg$msg_number"></a><a href="#$msg_number">Message #$msg_number</a> received at |.
360 html_escape("$received\@$hostname") .
361 q| (<a href="| . html_escape(bug_url($bug_number, msg=>$msg_number)) . '">full text</a>'.
362 q|, <a href="| . html_escape(bug_url($bug_number, msg=>$msg_number,mbox=>'yes')) .'">mbox</a>)'.":</p>\n";
363 $output .= handle_email_message($record->{text},
365 msg_num => $msg_number,
369 die "Unknown record type $_";