$CGI::POST_MAX = 1024 * 100; # max 100K posts
$CGI::DISABLE_UPLOADS = 1; # no uploads
-use URI::Escape;
-
-use File::Path;
-use File::Temp qw();
-
-use Encode qw/encode decode/;
-
use Emesinae::Bug;
use Emesinae::Common;
use Emesinae::CGI;
+use Emesinae::CGI::Message;
readconfig;
my $dbh = opendb;
print "\n";
-sub hdr ($$) {
- my ( $tag, $value ) = @_;
- return undef unless $value;
- $value = encode( 'utf-8', decode( 'MIME-Header', $value ) );
- return b($tag) . ": " . htmlsanit($value);
-}
-
sub msgcmp {
my $atime = $a->{present} ? $a->{date}->time : 0;
my $btime = $b->{present} ? $b->{date}->time : 0;
return $atime <=> $btime;
}
-sub archive_list ($) {
- my $msgid = shift;
- my @archives;
- while ( my ( $name, $url ) = each( %{ $c{Archives} } ) ) {
- $url =~ s/<MSGID>/$msgid/;
- push @archives, a( { href => $url }, $name );
- }
- return @archives;
-}
-
-sub resubject ($) {
- my $m = shift;
- my $s = $m->{subject}->text;
- $s = "Re: $s" unless $s =~ m/^Re: /;
- return "$s";
-}
-
-sub reply_link ($) {
- my $m = shift;
- my $p = $m->{present};
-
- my %hdrs = ( "In-Reply-To" => $m->{msgid}, );
-
- my $to = join( ",", $m->{from}->addresses );
-
- my @cc;
- push @cc, $m->{to}->addresses if $p;
- push @cc, $m->{cc}->addresses if $p;
-
- $hdrs{cc} = join( ",", @cc ) if @cc;
-
- $hdrs{subject} =
- $p
- ? resubject($m)
- : "Re: Bug " . $bug->{id} . ": " . $bug->{title};
-
- my $args =
- join( "&", map { $_ . "=" . uri_escape( $hdrs{$_} ) } keys %hdrs );
- return a( { href => "mailto:${to}?$args" }, "Reply to this message" );
-}
-
-sub raw_link ($) {
- my $m = shift;
- return msglink( $m, "Retrieve Raw Message", "/raw" );
-}
-
-sub getmailbody # From Debbugs
-{
- my $entity = shift;
- my $type = $entity->effective_type;
-
- if ( $type eq 'text/plain'
- or ( $type =~ m#text/?# and $type ne 'text/html' )
- or $type eq 'application/pgp' )
- {
- return $entity;
- }
- elsif ( $type eq 'multipart/alternative' ) {
-
- # RFC 2046 says we should use the last part we recognize.
- for my $part ( reverse $entity->parts ) {
- my $ret = getmailbody($part);
- return $ret if $ret;
- }
- }
- else {
-
- # For other multipart types, we just pretend they're
- # multipart/mixed and run through in order.
- for my $part ( $entity->parts ) {
- my $ret = getmailbody($part);
- return $ret if $ret;
- }
- }
- return undef;
-}
-
-sub getmailparts {
- my $entity = shift;
- my @ret;
- if ( $entity->is_multipart ) {
- for my $part ( $entity->parts ) {
- push @ret, getmailparts($part);
- }
- }
- else {
- push @ret, $entity;
- }
- return @ret;
-}
-
-sub parthdr {
- my ( $entity, $m, $nr ) = @_;
- my $head = $entity->head;
-
- my $disposition = $head->mime_attr('content-disposition');
- $disposition = 'inline' if not defined $disposition or $disposition eq '';
- my $type = $entity->effective_type;
- my $filename = $entity->head->recommended_filename;
- $filename = '' unless defined $filename;
- $filename = encode( 'utf-8', decode( 'MIME-Header', $filename ) );
-
- my $msgid = $m->id;
- return
- "["
- . msglink( $m, $filename ? $filename : "Part $nr", "/part/$nr" )
- . " ($type, $disposition)" . "]";
-}
-
foreach my $m ( sort msgcmp $bug->messages ) {
- print comment( "Message "
- . $m->{id} . ": "
- . $m->{msgid}
- . " (type: "
- . $m->{msgtype}
- . ")" )
- . "\n";
-
- my $bodyent;
- my @body;
- my @parts;
-
- my @archives = archive_list( $m->{msgid} );
-
- if ( $m->{msgtype} eq "control-reply" ) {
- print p ( "Control reply; (" . msglink( $m, "Full Text" ) . ")" )
- . "\n";
- print hr . "\n";
- next;
- }
-
- print pre(
- { -class => "headers" },
- join(
- "\n",
- grep { $_ } (
- hdr( "From", $m->{from}->stringify ),
- hdr( "To", $m->{to}->stringify ),
- hdr( "Cc", $m->{cc}->stringify ),
- hdr( "Subject", $m->{subject}->stringify ),
- hdr( "Date", $m->{date}->stringify ),
- hdr( "Message-ID", $m->{msgid} )
- )
- )
- ) . "\n";
- print p(
- { -class => "msgcontrol" },
- "[ "
- . reply_link($m) . "; "
- . raw_link($m) . "; "
- . "Archives: "
- . join( ", ", @archives ) . " ]"
- ) . "\n";
-
- if ( $m->{present} ) {
- my $tempdir = File::Temp::tempdir();
- my $e = $m->get_mime($tempdir);
- my $et = $e->effective_type;
- $bodyent = getmailbody($e);
- push @body, $bodyent->bodyhandle->as_lines;
- rmtree $tempdir, 0, 1;
- @parts = getmailparts($e);
-
- # Strip leading and trailing blank lines
- shift @body while @body and $body[0] !~ /\S/;
- pop @body while @body and $body[$#body] !~ /\S/;
-
- my $nr = 1;
- foreach my $part (@parts) {
- print pre( { -class => "mime" }, parthdr( $part, $m, $nr ) ) . "\n"
- unless $#parts eq 0;
- print pre( { -class => "body" }, htmlsanit( join( "", @body ) ) )
- . "\n"
- if $part == $bodyent;
- $nr++;
- }
- }
- else {
- @body = ("Message not present in archive\n");
- print pre( { -class => "body" }, htmlsanit( join( "", @body ) ) )
- . "\n";
- }
-
+ format_html($m, $bug);
print hr . "\n";
}
--- /dev/null
+package Emesinae::CGI::Message;
+
+use warnings;
+use strict;
+
+use CGI qw/:standard/;
+use CGI::Carp qw(fatalsToBrowser);
+
+use URI::Escape;
+
+use File::Path;
+use File::Temp qw();
+
+use Encode qw/encode decode/;
+
+use Emesinae::Message;
+use Emesinae::Common;
+use Emesinae::CGI;
+
+BEGIN {
+ use Exporter ();
+ our ( $VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS );
+ $VERSION = 1.00;
+ @ISA = qw(Exporter);
+ @EXPORT = qw(
+ format_html
+ );
+ %EXPORT_TAGS = ();
+
+ @EXPORT_OK = qw();
+}
+
+sub hdr ($$) {
+ my ( $tag, $value ) = @_;
+ return undef unless $value;
+ $value = encode( 'utf-8', decode( 'MIME-Header', $value ) );
+ return b($tag) . ": " . htmlsanit($value);
+}
+
+sub archive_list ($) {
+ my $msgid = shift;
+ my @archives;
+ while ( my ( $name, $url ) = each( %{ $c{Archives} } ) ) {
+ $url =~ s/<MSGID>/$msgid/;
+ push @archives, a( { href => $url }, $name );
+ }
+ return @archives;
+}
+
+sub resubject ($) {
+ my $m = shift;
+ my $s = $m->{subject}->text;
+ $s = "Re: $s" unless $s =~ m/^Re: /;
+ return "$s";
+}
+
+sub reply_link ($$) {
+ my $m = shift;
+ my $bug = shift;
+
+ my $p = $m->{present};
+
+ my %hdrs = ( "In-Reply-To" => $m->{msgid}, );
+
+ my $to = join( ",", $m->{from}->addresses );
+
+ my @cc;
+ push @cc, $m->{to}->addresses if $p;
+ push @cc, $m->{cc}->addresses if $p;
+
+ $hdrs{cc} = join( ",", @cc ) if @cc;
+
+ $hdrs{subject} =
+ $p
+ ? resubject($m)
+ : "Re: Bug " . $bug->{id} . ": " . $bug->{title};
+
+ my $args =
+ join( "&", map { $_ . "=" . uri_escape( $hdrs{$_} ) } keys %hdrs );
+ return a( { href => "mailto:${to}?$args" }, "Reply to this message" );
+}
+
+sub raw_link ($) {
+ my $m = shift;
+ return msglink( $m, "Retrieve Raw Message", "/raw" );
+}
+
+sub getmailbody # From Debbugs
+{
+ my $entity = shift;
+ my $type = $entity->effective_type;
+
+ if ( $type eq 'text/plain'
+ or ( $type =~ m#text/?# and $type ne 'text/html' )
+ or $type eq 'application/pgp' )
+ {
+ return $entity;
+ }
+ elsif ( $type eq 'multipart/alternative' ) {
+
+ # RFC 2046 says we should use the last part we recognize.
+ for my $part ( reverse $entity->parts ) {
+ my $ret = getmailbody($part);
+ return $ret if $ret;
+ }
+ }
+ else {
+
+ # For other multipart types, we just pretend they're
+ # multipart/mixed and run through in order.
+ for my $part ( $entity->parts ) {
+ my $ret = getmailbody($part);
+ return $ret if $ret;
+ }
+ }
+ return undef;
+}
+
+sub getmailparts {
+ my $entity = shift;
+ my @ret;
+ if ( $entity->is_multipart ) {
+ for my $part ( $entity->parts ) {
+ push @ret, getmailparts($part);
+ }
+ }
+ else {
+ push @ret, $entity;
+ }
+ return @ret;
+}
+
+sub parthdr {
+ my ( $entity, $m, $nr ) = @_;
+ my $head = $entity->head;
+
+ my $disposition = $head->mime_attr('content-disposition');
+ $disposition = 'inline' if not defined $disposition or $disposition eq '';
+ my $type = $entity->effective_type;
+ my $filename = $entity->head->recommended_filename;
+ $filename = '' unless defined $filename;
+ $filename = encode( 'utf-8', decode( 'MIME-Header', $filename ) );
+
+ my $msgid = $m->id;
+ return
+ "["
+ . msglink( $m, $filename ? $filename : "Part $nr", "/part/$nr" )
+ . " ($type, $disposition)" . "]";
+}
+
+sub format_html ($$) {
+ my $m = shift;
+ my $bug = shift;
+
+ print comment( "Message "
+ . $m->{id} . ": "
+ . $m->{msgid}
+ . " (type: "
+ . $m->{msgtype}
+ . ")" )
+ . "\n";
+
+ my $bodyent;
+ my @body;
+ my @parts;
+
+ my @archives = archive_list( $m->{msgid} );
+
+ if ( $m->{msgtype} eq "control-reply" ) {
+ print p ( "Control reply; (" . msglink( $m, "Full Text" ) . ")" )
+ . "\n";
+ print hr . "\n";
+ next;
+ }
+
+ print pre(
+ { -class => "headers" },
+ join(
+ "\n",
+ grep { $_ } (
+ hdr( "From", $m->{from}->stringify ),
+ hdr( "To", $m->{to}->stringify ),
+ hdr( "Cc", $m->{cc}->stringify ),
+ hdr( "Subject", $m->{subject}->stringify ),
+ hdr( "Date", $m->{date}->stringify ),
+ hdr( "Message-ID", $m->{msgid} )
+ )
+ )
+ ) . "\n";
+ print p(
+ { -class => "msgcontrol" },
+ "[ "
+ . reply_link($m, $bug) . "; "
+ . raw_link($m) . "; "
+ . "Archives: "
+ . join( ", ", @archives ) . " ]"
+ ) . "\n";
+
+ if ( $m->{present} ) {
+ my $tempdir = File::Temp::tempdir();
+ my $e = $m->get_mime($tempdir);
+ my $et = $e->effective_type;
+ $bodyent = getmailbody($e);
+ push @body, $bodyent->bodyhandle->as_lines;
+ rmtree $tempdir, 0, 1;
+ @parts = getmailparts($e);
+
+ # Strip leading and trailing blank lines
+ shift @body while @body and $body[0] !~ /\S/;
+ pop @body while @body and $body[$#body] !~ /\S/;
+
+ my $nr = 1;
+ foreach my $part (@parts) {
+ print pre( { -class => "mime" }, parthdr( $part, $m, $nr ) ) . "\n"
+ unless $#parts eq 0;
+ print pre( { -class => "body" }, htmlsanit( join( "", @body ) ) )
+ . "\n"
+ if $part == $bodyent;
+ $nr++;
+ }
+ }
+ else {
+ @body = ("Message not present in archive\n");
+ print pre( { -class => "body" }, htmlsanit( join( "", @body ) ) )
+ . "\n";
+ }
+}
+
+1;
projects / people / aperard / emesinae.git / commitdiff