X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=Debbugs%2FCGI.pm;h=9cc4d512426310e48b15f048722834ac34f7b160;hb=1a1fa6f0af2be9d4076d9aad5f5a84c5fb3d9a8a;hp=e2780036b5262d44fdb56dbf716bcdac45b35b2d;hpb=60ec861a3cb25564a6f2c05e10beb049faad2f4c;p=debbugs.git
diff --git a/Debbugs/CGI.pm b/Debbugs/CGI.pm
index e278003..9cc4d51 100644
--- a/Debbugs/CGI.pm
+++ b/Debbugs/CGI.pm
@@ -34,7 +34,7 @@ None known.
use warnings;
use strict;
use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
-use base qw(Exporter);
+use Exporter qw(import);
use Debbugs::URI;
use HTML::Entities;
@@ -50,7 +50,8 @@ use POSIX qw(ceil);
use Storable qw(dclone);
use List::Util qw(max);
-
+use File::stat;
+use Digest::MD5 qw(md5_hex);
use Carp;
use Debbugs::Text qw(fill_in_template);
@@ -77,6 +78,7 @@ BEGIN{
usertags => [qw(add_user)],
misc => [qw(maint_decode)],
package_search => [qw(@package_search_key_order %package_search_keys)],
+ cache => [qw(calculate_etag etag_does_not_match)],
#status => [qw(getbugstatus)],
);
@EXPORT_OK = ();
@@ -161,7 +163,9 @@ sub munge_url {
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);
+ $new_url->query_form(@new_param,
+ map {($_,$params{$_})}
+ sort keys %params);
return $new_url->as_string;
}
@@ -196,7 +200,7 @@ width and height are passed.
sub version_url{
my %params = validate_with(params => \@_,
- spec => {package => {type => SCALAR,
+ spec => {package => {type => SCALAR|ARRAYREF,
},
found => {type => ARRAYREF,
default => [],
@@ -288,7 +292,9 @@ sub cgi_parameters {
sub quitcgi {
- my $msg = shift;
+ my ($msg, $status) = @_;
+ $status //= '500 Internal Server Error';
+ print "Status: $status\n";
print "Content-Type: text/html\n\n";
print fill_in_template(template=>'cgi/quit',
variables => {msg => $msg}
@@ -297,7 +303,7 @@ sub quitcgi {
}
-=head HTML
+=head1 HTML
=head2 htmlize_packagelinks
@@ -400,11 +406,15 @@ sub package_links {
}
my @links = ();
for my $type (qw(src package)) {
- push @links, map {(munge_url('pkgreport.cgi?',
+ push @links, map {my $t_type = $type;
+ if ($_ =~ s/^src://) {
+ $t_type = 'src';
+ }
+ (munge_url('pkgreport.cgi?',
%options,
- $type => $_,
+ $t_type => $_,
),
- $_);
+ ($t_type eq 'src'?'src:':'').$_);
} make_list($param{$type}) if exists $param{$type};
}
for my $type (qw(maint owner submitter correspondent)) {
@@ -536,8 +546,8 @@ the split links with commas and spaces.
sub maybelink {
my ($links,$regex,$join) = @_;
if (not defined $regex and not defined $join) {
- $links =~ s{((?:ftp|http|https)://[\S~-]+?/?)([\)\'\:\.\,]?(?:\s|\.<|$))}
- {q().html_escape($1).q().$2}geimo;
+ $links =~ s{(.*?)((?:(?:ftp|http|https)://[\S~-]+?/?)?)([\)\'\:\.\,]?(?:\s|\.<|$))}
+ {html_escape($1).(length $2?q().html_escape($2).q():'').html_escape($3)}geimo;
return $links;
}
$join = ' ' if not defined $join;
@@ -614,10 +624,6 @@ sub htmlize_maintlinks {
return htmlize_addresslinks($prefixfunc, \&mainturl, $maints);
}
-
-our $_maintainer;
-our $_maintainer_rev;
-
=head2 bug_linklist
bug_linklist($separator,$class,@bugs)
@@ -833,7 +839,6 @@ sub option_form{
for my $key (keys %{$param{form_option}}) {
# strip out leader; shouldn't be anything here without one,
# but skip stupid things anyway
- my $o_key = $key;
next unless $key =~ s/^\Q$form_option_leader\E//;
if ($key =~ /^add_(.+)$/) {
# this causes a specific parameter to be added
@@ -867,7 +872,8 @@ sub option_form{
if (defined $value and $o_value eq $value) {
$selected = ' selected';
}
- $output .= qq(\n);
+ $output .= q(\n);
}
return $output;
};
@@ -877,6 +883,8 @@ sub option_form{
return Debbugs::Text::fill_in_template(template=>$param{template},
(exists $param{language}?(language=>$param{language}):()),
variables => $variables,
+ hole_var => {'&html_escape' => \&html_escape,
+ },
);
}
@@ -927,6 +935,77 @@ sub maint_decode {
wantarray ? @output : $output[0];
}
+=head1 cache
+
+=head2 calculate_etags
+
+ calculate_etags(files => [qw(list of files)],additional_data => [qw(any additional data)]);
+
+=cut
+
+sub calculate_etags {
+ my %param =
+ validate_with(params => \@_,
+ spec => {files => {type => ARRAYREF,
+ default => [],
+ },
+ additional_data => {type => ARRAYREF,
+ default => [],
+ },
+ },
+ );
+ my @additional_data = @{$param{additional_data}};
+ for my $file (@{$param{files}}) {
+ my $st = stat($file) or warn "Unable to stat $file: $!";
+ push @additional_data,$st->mtime;
+ push @additional_data,$st->size;
+ }
+ return(md5_hex(join('',sort @additional_data)));
+}
+
+=head2 etag_does_not_match
+
+ etag_does_not_match(cgi=>$q,files=>[qw(list of files)],
+ additional_data=>[qw(any additional data)])
+
+
+Checks to see if the CGI request contains an etag which matches the calculated
+etag.
+
+If there wasn't an etag given, or the etag given doesn't match, return the etag.
+
+If the etag does match, return 0.
+
+=cut
+
+sub etag_does_not_match {
+ my %param =
+ validate_with(params => \@_,
+ spec => {files => {type => ARRAYREF,
+ default => [],
+ },
+ additional_data => {type => ARRAYREF,
+ default => [],
+ },
+ cgi => {type => OBJECT},
+ },
+ );
+ my $submitted_etag =
+ $param{cgi}->http('if-none-match');
+ my $etag =
+ calculate_etags(files=>$param{files},
+ additional_data=>$param{additional_data});
+ if (not defined $submitted_etag or
+ length($submitted_etag) != 32
+ or $etag ne $submitted_etag
+ ) {
+ return $etag;
+ }
+ if ($etag eq $submitted_etag) {
+ return 0;
+ }
+}
+
1;