X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=Debbugs%2FCGI.pm;h=dffa8ec1e021a896f1d42c782f76807dadda395c;hb=b1252b6797aa6a79d00a32165fb2fa8fb1bd9318;hp=f4cd20e06df112efd2daa84e0d4d1780f2d0e1b9;hpb=8e72be6352972cf95a53d238dddbd5fd591ae0c0;p=debbugs.git diff --git a/Debbugs/CGI.pm b/Debbugs/CGI.pm index f4cd20e..dffa8ec 100644 --- a/Debbugs/CGI.pm +++ b/Debbugs/CGI.pm @@ -17,8 +17,6 @@ Debbugs::CGI -- General routines for the cgi scripts use Debbugs::CGI qw(:url :html); -html_escape(bug_url($ref,mbox=>'yes',mboxstatus=>'yes')); - =head1 DESCRIPTION This module is a replacement for parts of common.pl; subroutines in @@ -34,37 +32,19 @@ None known. use warnings; use strict; use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); -use base qw(Exporter); - -use Debbugs::URI; -use HTML::Entities; -use Debbugs::Common qw(getparsedaddrs make_list); -use Params::Validate qw(validate_with :types); +use Exporter qw(import); -use Debbugs::Config qw(:config); -use Debbugs::Status qw(splitpackages isstrongseverity); -use Debbugs::User qw(); - -use Mail::Address; -use POSIX qw(ceil); -use Storable qw(dclone); - -use List::Util qw(max); - -use Carp; - -use Debbugs::Text qw(fill_in_template); +use feature qw(state); our %URL_PARAMS = (); - BEGIN{ ($VERSION) = q$Revision: 1.3 $ =~ /^Revision:\s+([^\s+])/; $DEBUG = 0 unless defined $DEBUG; @EXPORT = (); - %EXPORT_TAGS = (url => [qw(bug_url bug_links bug_linklist maybelink), - qw(set_url_params pkg_url version_url), + %EXPORT_TAGS = (url => [qw(bug_links bug_linklist maybelink), + qw(set_url_params version_url), qw(submitterurl mainturl munge_url), qw(package_links bug_links), ], @@ -77,6 +57,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 = (); @@ -84,6 +65,28 @@ BEGIN{ $EXPORT_TAGS{all} = [@EXPORT_OK]; } +use Debbugs::URI; +use URI::Escape; +use HTML::Entities; +use Debbugs::Common qw(getparsedaddrs make_list); +use Params::Validate qw(validate_with :types); + +use Debbugs::Config qw(:config); +use Debbugs::Status qw(splitpackages isstrongseverity); +use Debbugs::User qw(); + +use Mail::Address; +use POSIX qw(ceil); +use Storable qw(dclone); +use Scalar::Util qw(looks_like_number); + +use List::AllUtils qw(max); +use File::stat; +use Digest::MD5 qw(md5_hex); +use Carp; + +use Debbugs::Text qw(fill_in_template); + =head2 set_url_params @@ -106,44 +109,6 @@ sub set_url_params{ } -=head2 bug_url - - bug_url($ref,mbox=>'yes',mboxstat=>'yes'); - -Constructs urls which point to a specific - -XXX use Params::Validate - -=cut - -sub bug_url{ - my $ref = shift; - my %params; - if (@_ % 2) { - shift; - %params = (%URL_PARAMS,@_); - } - else { - %params = @_; - } - carp "bug_url is deprecated, use bug_links instead"; - - return munge_url('bugreport.cgi?',%params,bug=>$ref); -} - -sub pkg_url{ - my %params; - if (@_ % 2) { - shift; - %params = (%URL_PARAMS,@_); - } - else { - %params = @_; - } - carp "pkg_url is deprecated, use package_links instead"; - return munge_url('pkgreport.cgi?',%params); -} - =head2 munge_url my $url = munge_url($url,%params_to_munge); @@ -161,7 +126,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 +163,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 +255,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 +266,7 @@ sub quitcgi { } -=head HTML +=head1 HTML =head2 htmlize_packagelinks @@ -361,61 +330,99 @@ our @package_search_key_order = (package => 'in package', bugs => 'in bug', ); our %package_search_keys = @package_search_key_order; - +our %package_links_invalid_options = + map {($_,1)} (keys %package_search_keys, + qw(msg att)); sub package_links { + state $spec = + {(map { ($_,{type => SCALAR|ARRAYREF, + optional => 1, + }); + } keys %package_search_keys, + ## these are aliases for package + ## search keys + source => {type => SCALAR|ARRAYREF, + optional => 1, + }, + maintainer => {type => SCALAR|ARRAYREF, + optional => 1, + }, + ), + links_only => {type => BOOLEAN, + default => 0, + }, + class => {type => SCALAR, + default => '', + }, + separator => {type => SCALAR, + default => ', ', + }, + options => {type => HASHREF, + default => {}, + }, + }; my %param = validate_with(params => \@_, - spec => {(map { ($_,{type => SCALAR|ARRAYREF, - optional => 1, - }); - } keys %package_search_keys, - ), - links_only => {type => BOOLEAN, - default => 0, - }, - class => {type => SCALAR, - default => '', - }, - separator => {type => SCALAR, - default => ', ', - }, - options => {type => HASHREF, - default => {}, - }, - }, - normalize_keys => - sub { - my ($key) = @_; - my %map = (source => 'src', - maintainer => 'maint', - pkg => 'package', - ); - return $map{$key} if exists $map{$key}; - return $key; - } + spec => $spec, ); my %options = %{$param{options}}; - for ((keys %package_search_keys,qw(msg att))) { - delete $options{$_} if exists $options{$_}; - } + for (grep {$package_links_invalid_options{$_}} keys %options) { + delete $options{$_}; + } + ## remove aliases for source and maintainer + if (exists $param{source}) { + $param{src} = [exists $param{src}?make_list($param{src}):(), + make_list($param{source}), + ]; + delete $param{source}; + } + if (exists $param{maintainer}) { + $param{maint} = [exists $param{maint}?make_list($param{maint}):(), + make_list($param{maintainer}), + ]; + delete $param{maintainer}; + } + my $has_options = keys %options; my @links = (); for my $type (qw(src package)) { - push @links, map {(munge_url('pkgreport.cgi?', - %options, - $type => $_, - ), - $_); - } make_list($param{$type}) if exists $param{$type}; + next unless exists $param{$type}; + for my $target (make_list($param{$type})) { + my $t_type = $type; + if ($target =~ s/^src://) { + $t_type = 'source'; + } elsif ($t_type eq 'source') { + $target = 'src:'.$target; + } + if ($has_options) { + push @links, + (munge_url('pkgreport.cgi?', + %options, + $t_type => $target, + ), + $target); + } else { + push @links, + ('pkgreport.cgi?'.$t_type.'='.uri_escape_utf8($target), + $target); + } + } } for my $type (qw(maint owner submitter correspondent)) { - push @links, map {my $addr = getparsedaddrs($_); - $addr = defined $addr?$addr->address:''; - (munge_url('pkgreport.cgi?', - %options, - $type => $addr, - ), - $_); - } make_list($param{$type}) if exists $param{$type}; + next unless exists $param{$type}; + for my $target (make_list($param{$type})) { + if ($has_options) { + push @links, + (munge_url('pkgreport.cgi?', + %options, + $type => $target), + $target); + } else { + push @links, + ('pkgreport.cgi?'. + $type.'='.uri_escape_utf8($target), + $target); + } + } } my @return = (); my ($link,$link_name); @@ -462,36 +469,47 @@ returning htmlized links. =cut sub bug_links { + state $spec = {bug => {type => SCALAR|ARRAYREF, + optional => 1, + }, + links_only => {type => BOOLEAN, + default => 0, + }, + class => {type => SCALAR, + default => '', + }, + separator => {type => SCALAR, + default => ', ', + }, + options => {type => HASHREF, + default => {}, + }, + }; my %param = validate_with(params => \@_, - spec => {bug => {type => SCALAR|ARRAYREF, - optional => 1, - }, - links_only => {type => BOOLEAN, - default => 0, - }, - class => {type => SCALAR, - default => '', - }, - separator => {type => SCALAR, - default => ', ', - }, - options => {type => HASHREF, - default => {}, - }, - }, + spec => $spec, ); my %options = %{$param{options}}; for (qw(bug)) { delete $options{$_} if exists $options{$_}; } + my $has_options = keys %options; my @links; - push @links, map {(munge_url('bugreport.cgi?', - %options, - bug => $_, - ), - $_); - } make_list($param{bug}) if exists $param{bug}; + if ($has_options) { + push @links, map {(munge_url('bugreport.cgi?', + %options, + bug => $_, + ), + $_); + } make_list($param{bug}) if exists $param{bug}; + } else { + push @links, + map {my $b = ceil($_); + ('bugreport.cgi?bug='.$b, + $b)} + grep {looks_like_number($_)} + make_list($param{bug}) if exists $param{bug}; + } my @return; my ($link,$link_name); my $class = ''; @@ -536,8 +554,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; @@ -606,7 +624,7 @@ sub emailfromrfc822{ return $addr; } -sub mainturl { package_links(maint => $_[0], links_only => 1); } +sub mainturl { package_links(maintainer => $_[0], links_only => 1); } sub submitterurl { package_links(submitter => $_[0], links_only => 1); } sub htmlize_maintlinks { my ($prefixfunc, $maints) = @_; @@ -614,10 +632,6 @@ sub htmlize_maintlinks { return htmlize_addresslinks($prefixfunc, \&mainturl, $maints); } - -our $_maintainer; -our $_maintainer_rev; - =head2 bug_linklist bug_linklist($separator,$class,@bugs) @@ -627,8 +641,7 @@ link class C<$class>. XXX Use L; we want to be able to support query arguments here too; we should be able to combine bug_links and this -function into one. [Hell, bug_url should be one function with this one -too.] +function into one. =cut @@ -833,7 +846,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 @@ -857,27 +869,12 @@ sub option_form{ # we'll add extra comands here once I figure out what they # should be } - # add in a few utility routines - $variables->{output_select_options} = sub { - my ($options,$value) = @_; - my @options = @{$options}; - my $output = ''; - while (my ($o_value,$name) = splice @options,0,2) { - my $selected = ''; - if (defined $value and $o_value eq $value) { - $selected = ' selected'; - } - $output .= q(\n); - } - return $output; - }; - $variables->{make_list} = sub { make_list(@_); - }; # now at this point, we're ready to create the template return Debbugs::Text::fill_in_template(template=>$param{template}, (exists $param{language}?(language=>$param{language}):()), variables => $variables, + hole_var => {'&html_escape' => \&html_escape, + }, ); } @@ -928,6 +925,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;