X-Git-Url: https://git.donarmstrong.com/?p=debbugs.git;a=blobdiff_plain;f=Debbugs%2FCGI.pm;h=7cc7f4166481335a7d9a6c6fda95b0f2fe694602;hp=e18891ab32c1a1882c4795548f03eb0050884534;hb=06424150844462de782ae112aa26c80dfa8d9401;hpb=343464a69a83b5b2f1e956386482baaaccbc835c diff --git a/Debbugs/CGI.pm b/Debbugs/CGI.pm index e18891a..7cc7f41 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,31 +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 Debbugs::Config qw(:config); -use Debbugs::Status qw(splitpackages isstrongseverity); -use Mail::Address; -use POSIX qw(ceil); -use Storable qw(dclone); +use Exporter qw(import); -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), ], @@ -67,14 +53,39 @@ BEGIN{ ], util => [qw(cgi_parameters quitcgi), ], + forms => [qw(option_form form_options_and_normal_param)], + 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 = (); - Exporter::export_ok_tags(qw(url html util misc)); + Exporter::export_ok_tags(keys %EXPORT_TAGS); $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 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 @@ -97,41 +108,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 = @_; - } - return munge_url('bugreport.cgi?',%params,bug=>$ref); -} - -sub pkg_url{ - my %params; - if (@_ % 2) { - shift; - %params = (%URL_PARAMS,@_); - } - else { - %params = @_; - } - return munge_url('pkgreport.cgi?',%params); -} - =head2 munge_url my $url = munge_url($url,%params_to_munge); @@ -149,7 +125,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; } @@ -184,7 +162,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 => [], @@ -276,7 +254,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} @@ -285,7 +265,7 @@ sub quitcgi { } -=head HTML +=head1 HTML =head2 htmlize_packagelinks @@ -293,7 +273,7 @@ sub quitcgi { Given a scalar containing a list of packages separated by something that L can separate, returns a -formatted set of links to packages. +formatted set of links to packages in html. =cut @@ -302,14 +282,12 @@ sub htmlize_packagelinks { return '' unless defined $pkgs and $pkgs ne ''; my @pkglist = splitpackages($pkgs); - carp "htmlize_packagelinks is deprecated"; + carp "htmlize_packagelinks is deprecated, use package_links instead"; return 'Package' . (@pkglist > 1 ? 's' : '') . ': ' . - join(', ', - package_links(package =>\@pkglist, - class => 'submitter' - ) - ); + package_links(package =>\@pkglist, + class => 'submitter' + ); } =head2 package_links @@ -324,7 +302,7 @@ Given a list of packages, return a list of html which links to the package =item submitter -- arrayref or scalar of submitter(s) -=item source -- arrayref or scalar of source(s) +=item src -- arrayref or scalar of source(s) =item maintainer -- arrayref or scalar of maintainer(s) @@ -337,52 +315,114 @@ returning htmlized links. =cut +our @package_search_key_order = (package => 'in package', + tag => 'tagged', + severity => 'with severity', + src => 'in source package', + maint => 'in packages maintained by', + submitter => 'submitted by', + owner => 'owned by', + status => 'with status', + affects => 'which affect package', + correspondent => 'with mail from', + newest => 'newest bugs', + 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 => {package => {type => SCALAR|ARRAYREF, - optional => 1, - }, - source => {type => SCALAR|ARRAYREF, - optional => 1, - }, - maintainer => {type => SCALAR|ARRAYREF, - optional => 1, - }, - submitter => {type => SCALAR|ARRAYREF, - optional => 1, - }, - owner => {type => SCALAR|ARRAYREF, - optional => 1, - }, - links_only => {type => BOOLEAN, - default => 0, - }, - class => {type => SCALAR, - default => '', - }, - separator => {type => SCALAR, - default => ', ', - }, - }, + spec => $spec, ); + my %options = %{$param{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 = (); - push @links, map {(pkg_url(source => $_),$_) - } make_list($param{source}) if exists $param{source}; - push @links, map {my $addr = getparsedaddrs($_); - $addr = defined $addr?$addr->address:''; - (pkg_url(maint => $addr),$_) - } make_list($param{maintainer}) if exists $param{maintainer}; - push @links, map {my $addr = getparsedaddrs($_); - $addr = defined $addr?$addr->address:''; - (pkg_url(owner => $addr),$_) - } make_list($param{owner}) if exists $param{owner}; - push @links, map {my $addr = getparsedaddrs($_); - $addr = defined $addr?$addr->address:''; - (pkg_url(submitter => $addr),$_) - } make_list($param{submitter}) if exists $param{submitter}; - push @links, map {(pkg_url(pkg => $_), - html_escape($_)) - } make_list($param{package}) if exists $param{package}; + for my $type (qw(src package)) { + 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)) { + 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); my $class = ''; @@ -438,11 +478,33 @@ sub bug_links { class => {type => SCALAR, default => '', }, + separator => {type => SCALAR, + default => ', ', + }, + options => {type => HASHREF, + default => {}, + }, }, ); + my %options = %{$param{options}}; + + for (qw(bug)) { + delete $options{$_} if exists $options{$_}; + } + my $has_options = keys %options; my @links; - push @links, map {(bug_url($_),$_) - } 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 {('bugreport.cgi?bug='.uri_escape_utf8($_), + $_)} + make_list($param{bug}) if exists $param{bug}; + } my @return; my ($link,$link_name); my $class = ''; @@ -460,7 +522,12 @@ sub bug_links { html_escape($link_name).q(); } } - return @return; + if (wantarray) { + return @return; + } + else { + return join($param{separator},@return); + } } @@ -481,6 +548,11 @@ 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|\.<|$))} + {html_escape($1).(length $2?q().html_escape($2).q():'').html_escape($3)}geimo; + return $links; + } $join = ' ' if not defined $join; my @return; my @segments; @@ -547,18 +619,14 @@ sub emailfromrfc822{ return $addr; } -sub mainturl { pkg_url(maint => emailfromrfc822($_[0])); } -sub submitterurl { pkg_url(submitter => emailfromrfc822($_[0])); } +sub mainturl { package_links(maintainer => $_[0], links_only => 1); } +sub submitterurl { package_links(submitter => $_[0], links_only => 1); } sub htmlize_maintlinks { my ($prefixfunc, $maints) = @_; carp "htmlize_maintlinks is deprecated"; return htmlize_addresslinks($prefixfunc, \&mainturl, $maints); } - -our $_maintainer; -our $_maintainer_rev; - =head2 bug_linklist bug_linklist($separator,$class,@bugs) @@ -568,17 +636,258 @@ 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 sub bug_linklist{ my ($sep,$class,@bugs) = @_; - return join($sep,bug_links(bug=>\@bugs,class=>$class)); + carp "bug_linklist is deprecated; use bug_links instead"; + return scalar bug_links(bug=>\@bugs,class=>$class,separator=>$sep); +} + + +sub add_user { + my ($user,$usertags,$bug_usertags,$seen_users,$cats,$hidden) = @_; + $seen_users = {} if not defined $seen_users; + $bug_usertags = {} if not defined $bug_usertags; + $usertags = {} if not defined $usertags; + $cats = {} if not defined $cats; + $hidden = {} if not defined $hidden; + return if exists $seen_users->{$user}; + $seen_users->{$user} = 1; + + my $u = Debbugs::User::get_user($user); + + my %vis = map { $_, 1 } @{$u->{"visible_cats"}}; + for my $c (keys %{$u->{"categories"}}) { + $cats->{$c} = $u->{"categories"}->{$c}; + $hidden->{$c} = 1 unless defined $vis{$c}; + } + for my $t (keys %{$u->{"tags"}}) { + $usertags->{$t} = [] unless defined $usertags->{$t}; + push @{$usertags->{$t}}, @{$u->{"tags"}->{$t}}; + } + + %{$bug_usertags} = (); + for my $t (keys %{$usertags}) { + for my $b (@{$usertags->{$t}}) { + $bug_usertags->{$b} = [] unless defined $bug_usertags->{$b}; + push @{$bug_usertags->{$b}}, $t; + } + } +} + + + +=head1 Forms + +=cut + +=head2 form_options_and_normal_param + + my ($form_option,$param) = form_options_and_normal_param(\%param) + if $param{form_options}; + my $form_option = form_options_and_normal_param(\%param) + if $param{form_options}; + +Translates from special form_options to a set of parameters which can +be used to run the current page. + +The idea behind this is to allow complex forms to relatively easily +cause options that the existing cgi scripts understand to be set. + +Currently there are two commands which are understood: +combine, and concatenate. + +=head3 combine + +Combine works by entering key,value pairs into the parameters using +the key field option input field, and the value field option input +field. + +For example, you would have + + + +which would combine the _fo_searchkey and _fo_searchvalue input fields, so + + + + +would yield foo=>'bar' in %param. + +=head3 concatenate + +Concatenate concatenates values into a single entry in a parameter + +For example, you would have + + + +which would combine the _fo_searchkey and _fo_searchvalue input fields, so + + + + +would yield foo=>'bar:baz' in %param. + + +=cut + +my $form_option_leader = '_fo_'; +sub form_options_and_normal_param{ + my ($orig_param) = @_; + # all form_option parameters start with _fo_ + my ($param,$form_option) = ({},{}); + for my $key (keys %{$orig_param}) { + if ($key =~ /^\Q$form_option_leader\E/) { + $form_option->{$key} = $orig_param->{$key}; + } + else { + $param->{$key} = $orig_param->{$key}; + } + } + # at this point, we check for commands + COMMAND: for my $key (keys %{$form_option}) { + $key =~ s/^\Q$form_option_leader\E//; + if (my ($key_name,$value_name) = + $key =~ /combine_key(\Q$form_option_leader\E.+) + _value(\Q$form_option_leader\E.+)$/x + ) { + next unless defined $form_option->{$key_name}; + next unless defined $form_option->{$value_name}; + my @keys = make_list($form_option->{$key_name}); + my @values = make_list($form_option->{$value_name}); + for my $i (0 .. $#keys) { + last if $i > $#values; + next if not defined $keys[$i]; + next if not defined $values[$i]; + __add_to_param($param, + $keys[$i], + $values[$i], + ); + } + } + elsif (my ($field,$concatenate_key,$fields) = + $key =~ /concatenate_into_(.+?)((?:_with_[^_])?) + ((?:\Q$form_option_leader\E.+?)+) + $/x + ) { + if (length $concatenate_key) { + $concatenate_key =~ s/_with_//; + } + else { + $concatenate_key = ':'; + } + my @fields = $fields =~ m/(\Q$form_option_leader\E.+?)(?:(?=\Q$form_option_leader\E)|$)/g; + my %field_list; + my $max_num = 0; + for my $f (@fields) { + next COMMAND unless defined $form_option->{$f}; + $field_list{$f} = [make_list($form_option->{$f})]; + $max_num = max($max_num,$#{$field_list{$f}}); + } + for my $i (0 .. $max_num) { + next unless @fields == grep {$i <= $#{$field_list{$_}} and + defined $field_list{$_}[$i]} @fields; + __add_to_param($param, + $field, + join($concatenate_key, + map {$field_list{$_}[$i]} @fields + ) + ); + } + } + } + return wantarray?($form_option,$param):$form_option; } +=head2 option_form + + print option_form(template=>'pkgreport_options', + param => \%param, + form_options => $form_options, + ) + + + +=cut + +sub option_form{ + my %param = validate_with(params => \@_, + spec => {template => {type => SCALAR, + }, + variables => {type => HASHREF, + default => {}, + }, + language => {type => SCALAR, + optional => 1, + }, + param => {type => HASHREF, + default => {}, + }, + form_options => {type => HASHREF, + default => {}, + }, + }, + ); + + # First, we need to see if we need to add particular types of + # parameters + my $variables = dclone($param{variables}); + $variables->{param} = dclone($param{param}); + for my $key (keys %{$param{form_option}}) { + # strip out leader; shouldn't be anything here without one, + # but skip stupid things anyway + next unless $key =~ s/^\Q$form_option_leader\E//; + if ($key =~ /^add_(.+)$/) { + # this causes a specific parameter to be added + __add_to_param($variables->{param}, + $1, + '' + ); + } + elsif ($key =~ /^delete_(.+?)(?:_(\d+))?$/) { + next unless exists $variables->{param}{$1}; + if (ref $variables->{param}{$1} eq 'ARRAY' and + defined $2 and + defined $variables->{param}{$1}[$2] + ) { + splice @{$variables->{param}{$1}},$2,1; + } + else { + delete $variables->{param}{$1}; + } + } + # we'll add extra comands here once I figure out what they + # should be + } + # 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, + }, + ); +} + +sub __add_to_param{ + my ($param,$key,@values) = @_; + + if (exists $param->{$key} and not + ref $param->{$key}) { + @{$param->{$key}} = [$param->{$key}, + @values + ]; + } + else { + push @{$param->{$key}}, @values; + } +} + + =head1 misc @@ -611,6 +920,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;