+# This module is part of debbugs, and is released
+# under the terms of the GPL version 2, or any later
+# version at your option.
+# See the file README and COPYING for more information.
+#
+# [Other people have contributed to this file; their copyrights should
+# go here too.]
+# Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
package Debbugs::CGI;
use base qw(Exporter);
use Debbugs::URI;
use HTML::Entities;
-use Debbugs::Common qw();
+use Debbugs::Common qw(getparsedaddrs);
use Params::Validate qw(validate_with :types);
use Debbugs::Config qw(:config);
+use Debbugs::Status qw(splitpackages);
use Mail::Address;
use POSIX qw(ceil);
+use Storable qw(dclone);
-my %URL_PARAMS = ();
+our %URL_PARAMS = ();
BEGIN{
@EXPORT = ();
%EXPORT_TAGS = (url => [qw(bug_url bug_links bug_linklist maybelink),
qw(set_url_params pkg_url version_url),
+ qw(submitterurl mainturl munge_url)
],
html => [qw(html_escape htmlize_bugs htmlize_packagelinks),
- qw(maybelink htmlize_addresslinks),
+ qw(maybelink htmlize_addresslinks htmlize_maintlinks),
],
- util => [qw(getparsedaddrs)]
+ util => [qw(cgi_parameters quitcgi),
+ ],
+ misc => [qw(maint_decode)],
#status => [qw(getbugstatus)],
);
@EXPORT_OK = ();
- Exporter::export_ok_tags(qw(url html util));
+ Exporter::export_ok_tags(qw(url html util misc));
$EXPORT_TAGS{all} = [@EXPORT_OK];
}
else {
%params = @_;
}
- my $url = Debbugs::URI->new('bugreport.cgi?');
- $url->query_form(bug=>$ref,%params);
- return $url->as_string;
+ return munge_url('bugreport.cgi?',%params,bug=>$ref);
}
sub pkg_url{
else {
%params = @_;
}
- my $url = Debbugs::URI->new('pkgreport.cgi?');
- $url->query_form(%params);
- return $url->as_string;
+ return munge_url('pkgreport.cgi?',%params);
+}
+
+=head2 munge_url
+
+ my $url = munge_url($url,%params_to_munge);
+
+Munges a url, replacing parameters with %params_to_munge as appropriate.
+
+=cut
+
+sub munge_url {
+ my $url = shift;
+ my %params = @_;
+ my $new_url = Debbugs::URI->new($url);
+ my @old_param = $new_url->query_form();
+ my @new_param;
+ while (my ($key,$value) = splice @old_param,0,2) {
+ push @new_param,($key,$value) unless exists $params{$key};
+ }
+ $new_url->query_form(@new_param,%params);
+ return $new_url->as_string;
}
+
=head2 version_url
version_url($package,$found,$fixed)
=cut
sub version_url{
- my ($package,$found,$fixed) = @_;
+ my ($package,$found,$fixed,$width,$height) = @_;
my $url = Debbugs::URI->new('version.cgi?');
$url->query_form(package => $package,
found => $found,
fixed => $fixed,
+ (defined $width)?(width => $width):(),
+ (defined $height)?(height => $height):(),
+ (defined $width or defined $height)?(collapse => 1):(info => 1),
);
return $url->as_string;
}
sub html_escape{
my ($string) = @_;
- return HTML::Entities::encode_entities($string)
+ return HTML::Entities::encode_entities($string,q(<>&"'));
}
-my %common_bugusertags;
-
-# =head2 get_bug_status
-#
-# my $status = getbugstatus($bug_num)
-#
-# my $status = getbugstatus($bug_num,$bug_index)
-#
-#
-# =cut
-#
-# sub get_bug_status {
-# my ($bugnum,$bugidx) = @_;
-#
-# my %status;
-#
-# if (defined $bugidx and exists $bugidx->{$bugnum}) {
-# %status = %{ $bugidx->{$bugnum} };
-# $status{pending} = $status{ status };
-# $status{id} = $bugnum;
-# return \%status;
-# }
-#
-# my $location = getbuglocation($bugnum, 'summary');
-# return {} if not length $location;
-# %status = %{ readbug( $bugnum, $location ) };
-# $status{id} = $bugnum;
-#
-#
-# if (defined $common_bugusertags{$bugnum}) {
-# $status{keywords} = "" unless defined $status{keywords};
-# $status{keywords} .= " " unless $status{keywords} eq "";
-# $status{keywords} .= join(" ", @{$common_bugusertags{$bugnum}});
-# }
-# $status{tags} = $status{keywords};
-# my %tags = map { $_ => 1 } split ' ', $status{tags};
-#
-# $status{"package"} =~ s/\s*$//;
-# $status{"package"} = 'unknown' if ($status{"package"} eq '');
-# $status{"severity"} = 'normal' if ($status{"severity"} eq '');
-#
-# $status{"pending"} = 'pending';
-# $status{"pending"} = 'forwarded' if (length($status{"forwarded"}));
-# $status{"pending"} = 'pending-fixed' if ($tags{pending});
-# $status{"pending"} = 'fixed' if ($tags{fixed});
-#
-# my @versions;
-# if (defined $common_version) {
-# @versions = ($common_version);
-# } elsif (defined $common_dist) {
-# @versions = getversions($status{package}, $common_dist, $common_arch);
-# }
-#
-# # TODO: This should probably be handled further out for efficiency and
-# # for more ease of distinguishing between pkg= and src= queries.
-# my @sourceversions = makesourceversions($status{package}, $common_arch,
-# @versions);
-#
-# if (@sourceversions) {
-# # Resolve bugginess states (we might be looking at multiple
-# # architectures, say). Found wins, then fixed, then absent.
-# my $maxbuggy = 'absent';
-# for my $version (@sourceversions) {
-# my $buggy = buggyversion($bugnum, $version, \%status);
-# if ($buggy eq 'found') {
-# $maxbuggy = 'found';
-# last;
-# } elsif ($buggy eq 'fixed' and $maxbuggy ne 'found') {
-# $maxbuggy = 'fixed';
-# }
-# }
-# if ($maxbuggy eq 'absent') {
-# $status{"pending"} = 'absent';
-# } elsif ($maxbuggy eq 'fixed') {
-# $status{"pending"} = 'done';
-# }
-# }
-#
-# if (length($status{done}) and
-# (not @sourceversions or not @{$status{fixed_versions}})) {
-# $status{"pending"} = 'done';
-# }
-#
-# return \%status;
-# }
+=head2 cgi_parameters
+ cgi_parameters
+
+Returns all of the cgi_parameters from a CGI script using CGI::Simple
+
+=cut
+
+sub cgi_parameters {
+ my %options = validate_with(params => \@_,
+ spec => {query => {type => OBJECT,
+ can => 'param',
+ },
+ single => {type => ARRAYREF,
+ default => [],
+ },
+ default => {type => HASHREF,
+ default => {},
+ },
+ },
+ );
+ my $q = $options{query};
+ my %single;
+ @single{@{$options{single}}} = (1) x @{$options{single}};
+ my %param;
+ for my $paramname ($q->param) {
+ if ($single{$paramname}) {
+ $param{$paramname} = $q->param($paramname);
+ }
+ else {
+ $param{$paramname} = [$q->param($paramname)];
+ }
+ }
+ for my $default (keys %{$options{default}}) {
+ if (not exists $param{$default}) {
+ # We'll clone the reference here to avoid surprises later.
+ $param{$default} = ref($options{default}{$default})?
+ dclone($options{default}{$default}):$options{default}{$default};
+ }
+ }
+ return %param;
+}
+
+
+sub quitcgi {
+ my $msg = shift;
+ print "Content-Type: text/html\n\n";
+ print "<HTML><HEAD><TITLE>Error</TITLE></HEAD><BODY>\n";
+ print "An error occurred. Dammit.\n";
+ print "Error was: $msg.\n";
+ print "</BODY></HTML>\n";
+ exit 0;
+}
+
+
+=head HTML
-# htmlize_bugs(bugs=>[@bugs]);
=head2 htmlize_bugs
htmlize_bugs({bug=>1,status=>\%status,extravars=>\%extra},{bug=>...}});
Turns a list of bugs into an html snippit of the bugs.
=cut
-
+# htmlize_bugs(bugs=>[@bugs]);
sub htmlize_bugs{
my @bugs = @_;
my @html;
return $result;
}
-# Split a package string from the status file into a list of package names.
-sub splitpackages {
- my $pkgs = shift;
- return unless defined $pkgs;
- return map lc, split /[ \t?,()]+/, $pkgs;
-}
-
-
=head2 htmlize_packagelinks
htmlize_packagelinks
my $prefix = (ref $prefixfunc) ?
$prefixfunc->(scalar @addrs):$prefixfunc;
return $prefix .
- join ', ', map
+ join(', ', map
{ sprintf qq(<a ${class}).
'href="%s">%s</a>',
$urlfunc->($_->address),
html_escape($_->format) ||
'(unknown)'
- } @addrs;
+ } @addrs
+ );
}
else {
my $prefix = (ref $prefixfunc) ?
}
}
+sub emailfromrfc822{
+ my $addr = getparsedaddrs($_[0] || "");
+ $addr = defined $addr?$addr->address:'';
+ return $addr;
+}
-
-my %_parsedaddrs;
-sub getparsedaddrs {
- my $addr = shift;
- return () unless defined $addr;
- return @{$_parsedaddrs{$addr}} if exists $_parsedaddrs{$addr};
- @{$_parsedaddrs{$addr}} = Mail::Address->parse($addr);
- return @{$_parsedaddrs{$addr}};
+sub mainturl { pkg_url(maint => emailfromrfc822($_[0])); }
+sub submitterurl { pkg_url(submitter => emailfromrfc822($_[0])); }
+sub htmlize_maintlinks {
+ my ($prefixfunc, $maints) = @_;
+ return htmlize_addresslinks($prefixfunc, \&mainturl, $maints);
}
+our $_maintainer;
+our $_maintainer_rev;
+
=head2 bug_links
bug_links($one_bug);
}
+=head1 misc
+
+=cut
+
+=head2 maint_decode
+
+ maint_decode
+
+Decodes the funky maintainer encoding.
+
+Don't ask me what in the world it does.
+
+=cut
+
+sub maint_decode {
+ my @input = @_;
+ return () unless @input;
+ my @output;
+ for my $input (@input) {
+ my $decoded = $input;
+ $decoded =~ s/-([^_]+)/-$1_-/g;
+ $decoded =~ s/_/-20_/g;
+ $decoded =~ s/^,(.*),(.*),([^,]+)$/$1-40_$2-20_-28_$3-29_/;
+ $decoded =~ s/^([^,]+),(.*),(.*),/$1-20_-3c_$2-40_$3-3e_/;
+ $decoded =~ s/\./-2e_/g;
+ $decoded =~ s/-([0-9a-f]{2})_/pack('H*',$1)/ge;
+ push @output,$decoded;
+ }
+ wantarray ? @output : $output[0];
+}
1;
projects / debbugs.git / blobdiff