X-Git-Url: https://git.donarmstrong.com/?p=debbugs.git;a=blobdiff_plain;f=Debbugs%2FCGI.pm;h=7cc7f4166481335a7d9a6c6fda95b0f2fe694602;hp=ea4d67b91a3f4e870a12ffb0d9735b7d7d0b36ee;hb=06424150844462de782ae112aa26c80dfa8d9401;hpb=89a8d08baf3d0f7693444d793e996087f0a36bb4 diff --git a/Debbugs/CGI.pm b/Debbugs/CGI.pm index ea4d67b..7cc7f41 100644 --- a/Debbugs/CGI.pm +++ b/Debbugs/CGI.pm @@ -1,3 +1,11 @@ +# 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 . package Debbugs::CGI; @@ -9,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 @@ -26,41 +32,60 @@ 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); -use Params::Validate qw(validate_with :types); -use Debbugs::Config qw(:config); -use Mail::Address; -use POSIX qw(ceil); -use Storable qw(dclone); +use Exporter qw(import); -my %URL_PARAMS = (); +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), - qw(submitterurl mainturl) + %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), ], html => [qw(html_escape htmlize_bugs htmlize_packagelinks), qw(maybelink htmlize_addresslinks htmlize_maintlinks), ], util => [qw(cgi_parameters quitcgi), - qw(getmaintainers getpseudodesc splitpackages) ], + 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)); + 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 @@ -83,62 +108,90 @@ sub set_url_params{ } -=head2 bug_url - - bug_url($ref,mbox=>'yes',mboxstat=>'yes'); +=head2 munge_url -Constructs urls which point to a specific + my $url = munge_url($url,%params_to_munge); -XXX use Params::Validate +Munges a url, replacing parameters with %params_to_munge as appropriate. =cut -sub bug_url{ - my $ref = shift; - my %params; - if (@_ % 2) { - shift; - %params = (%URL_PARAMS,@_); +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}; } - else { - %params = @_; - } - my $url = Debbugs::URI->new('bugreport.cgi?'); - $url->query_form(bug=>$ref,%params); - return $url->as_string; + $new_url->query_form(@new_param, + map {($_,$params{$_})} + sort keys %params); + return $new_url->as_string; } -sub pkg_url{ - my %params; - if (@_ % 2) { - shift; - %params = (%URL_PARAMS,@_); - } - else { - %params = @_; - } - my $url = Debbugs::URI->new('pkgreport.cgi?'); - $url->query_form(%params); - return $url->as_string; -} =head2 version_url - version_url($package,$found,$fixed) + version_url(package => $package,found => $found,fixed => $fixed) Creates a link to the version cgi script +=over + +=item package -- source package whose graph to display + +=item found -- arrayref of found versions + +=item fixed -- arrayref of fixed versions + +=item width -- optional width of graph + +=item height -- optional height of graph + +=item info -- display html info surrounding graph; defaults to 1 if +width and height are not passed. + +=item collapse -- whether to collapse the graph; defaults to 1 if +width and height are passed. + +=back + =cut sub version_url{ - my ($package,$found,$fixed,$width,$height) = @_; + my %params = validate_with(params => \@_, + spec => {package => {type => SCALAR|ARRAYREF, + }, + found => {type => ARRAYREF, + default => [], + }, + fixed => {type => ARRAYREF, + default => [], + }, + width => {type => SCALAR, + optional => 1, + }, + height => {type => SCALAR, + optional => 1, + }, + absolute => {type => BOOLEAN, + default => 0, + }, + collapse => {type => BOOLEAN, + default => 1, + }, + info => {type => BOOLEAN, + optional => 1, + }, + } + ); + if (not defined $params{width} and not defined $params{height}) { + $params{info} = 1 if not exists $params{info}; + } my $url = Debbugs::URI->new('version.cgi?'); - $url->query_form(package => $package, - found => $found, - fixed => $fixed, - (defined $width)?(width => $width):(), - (defined $height)?(height => $height):() - ); + $url->query_form(%params); return $url->as_string; } @@ -153,7 +206,7 @@ Escapes html entities by calling HTML::Entities::encode_entities; sub html_escape{ my ($string) = @_; - return HTML::Entities::encode_entities($string) + return HTML::Entities::encode_entities($string,q(<>&"')); } =head2 cgi_parameters @@ -201,182 +254,284 @@ 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 "Error\n"; - print "An error occurred. Dammit.\n"; - print "Error was: $msg.\n"; - print "\n"; + print fill_in_template(template=>'cgi/quit', + variables => {msg => $msg} + ); exit 0; } -my %common_bugusertags; - +=head1 HTML +=head2 htmlize_packagelinks -=head HTML + htmlize_packagelinks -=head2 htmlize_bugs +Given a scalar containing a list of packages separated by something +that L can separate, returns a +formatted set of links to packages in html. - htmlize_bugs({bug=>1,status=>\%status,extravars=>\%extra},{bug=>...}}); +=cut -Turns a list of bugs into an html snippit of the bugs. +sub htmlize_packagelinks { + my ($pkgs) = @_; + return '' unless defined $pkgs and $pkgs ne ''; + my @pkglist = splitpackages($pkgs); -=cut -# htmlize_bugs(bugs=>[@bugs]); -sub htmlize_bugs{ - my @bugs = @_; - my @html; + carp "htmlize_packagelinks is deprecated, use package_links instead"; - for my $bug (@bugs) { - my $html = sprintf "
  • #%d: %s\n
    ", - bug_url($bug->{bug}), $bug->{bug}, html_escape($bug->{status}{subject}); - $html .= htmlize_bugstatus($bug->{status}) . "\n"; - } - return @html; + return 'Package' . (@pkglist > 1 ? 's' : '') . ': ' . + package_links(package =>\@pkglist, + class => 'submitter' + ); } +=head2 package_links -sub htmlize_bugstatus { - my %status = %{$_[0]}; + join(', ', package_links(packages => \@packages)) - my $result = ""; +Given a list of packages, return a list of html which links to the package - my $showseverity; - if ($status{severity} eq $config{default_severity}) { - $showseverity = ''; - } elsif (isstrongseverity($status{severity})) { - $showseverity = "Severity: $status{severity};\n"; - } else { - $showseverity = "Severity: $status{severity};\n"; - } - - $result .= htmlize_packagelinks($status{"package"}, 1); - - my $showversions = ''; - if (@{$status{found_versions}}) { - my @found = @{$status{found_versions}}; - local $_; - s{/}{ } foreach @found; - $showversions .= join ', ', map html_escape($_), @found; - } - if (@{$status{fixed_versions}}) { - $showversions .= '; ' if length $showversions; - $showversions .= 'fixed: '; - my @fixed = @{$status{fixed_versions}}; - $showversions .= join ', ', map {s#/##; html_escape($_)} @fixed; - } - $result .= " ($showversions)" if length $showversions; - $result .= ";\n"; - - $result .= $showseverity; - $result .= htmlize_addresslinks("Reported by: ", \&submitterurl, - $status{originator}); - $result .= ";\nOwned by: " . html_escape($status{owner}) - if length $status{owner}; - $result .= ";\nTags: " - . html_escape(join(", ", sort(split(/\s+/, $status{tags})))) - . "" - if (length($status{tags})); - - $result .= ";\nMerged with ". - bug_linklist(', ', - 'submitter', - split(/ /,$status{mergedwith})) - if length $status{mergedwith}; - $result .= ";\nBlocked by ". - bug_linklist(", ", - 'submitter', - split(/ /,$status{blockedby})) - if length $status{blockedby}; - $result .= ";\nBlocks ". - bug_linklist(", ", - 'submitter', - split(/ /,$status{blocks}) - ) - if length $status{blocks}; - - my $days = 0; - if (length($status{done})) { - $result .= "
    Done: " . html_escape($status{done}); - $days = ceil($debbugs::gRemoveAge - -M buglog($status{id})); - if ($days >= 0) { - $result .= ";\nWill be archived" . ( $days == 0 ? " today" : $days == 1 ? " in $days day" : " in $days days" ) . ""; - } else { - $result .= ";\nArchived"; +=over + +=item package -- arrayref or scalar of package(s) + +=item submitter -- arrayref or scalar of submitter(s) + +=item src -- arrayref or scalar of source(s) + +=item maintainer -- arrayref or scalar of maintainer(s) + +=item links_only -- return only links, not htmlized links, defaults to +returning htmlized links. + +=item class -- class of the a href, defaults to '' + +=back + +=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 => $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 = (); + 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 = ''; + if (length $param{class}) { + $class = q( class=").html_escape($param{class}).q("); + } + while (($link,$link_name) = splice(@links,0,2)) { + if ($param{links_only}) { + push @return,$link + } + else { + push @return, + qq(). + html_escape($link_name).q(); } } + if (wantarray) { + return @return; + } else { - if (length($status{forwarded})) { - $result .= ";\nForwarded to " - . maybelink($status{forwarded}); - } - my $daysold = int((time - $status{date}) / 86400); # seconds to days - if ($daysold >= 7) { - my $font = ""; - my $efont = ""; - $font = "em" if ($daysold > 30); - $font = "strong" if ($daysold > 60); - $efont = "" if ($font); - $font = "<$font>" if ($font); - - my $yearsold = int($daysold / 365); - $daysold -= $yearsold * 365; - - $result .= ";\n $font"; - my @age; - push @age, "1 year" if ($yearsold == 1); - push @age, "$yearsold years" if ($yearsold > 1); - push @age, "1 day" if ($daysold == 1); - push @age, "$daysold days" if ($daysold > 1); - $result .= join(" and ", @age); - $result .= " old$efont"; - } - } - - $result .= "."; - - return $result; + return join($param{separator},@return); + } } -# 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 bug_links + join(', ', bug_links(bug => \@packages)) -=head2 htmlize_packagelinks +Given a list of bugs, return a list of html which links to the bugs - htmlize_packagelinks +=over -Given a scalar containing a list of packages separated by something -that L can separate, returns a -formatted set of links to packages. +=item bug -- arrayref or scalar of bug(s) -=cut +=item links_only -- return only links, not htmlized links, defaults to +returning htmlized links. -sub htmlize_packagelinks { - my ($pkgs,$strong) = @_; - return unless defined $pkgs and $pkgs ne ''; - my @pkglist = splitpackages($pkgs); +=item class -- class of the a href, defaults to '' - $strong = 0; - my $openstrong = $strong ? '' : ''; - my $closestrong = $strong ? '' : ''; +=back - return 'Package' . (@pkglist > 1 ? 's' : '') . ': ' . - join(', ', - map { - '' . - $openstrong . html_escape($_) . $closestrong . '' - } @pkglist - ); +=cut + +sub bug_links { + 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 => {}, + }, + }, + ); + my %options = %{$param{options}}; + + for (qw(bug)) { + delete $options{$_} if exists $options{$_}; + } + my $has_options = keys %options; + my @links; + 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 = ''; + if (length $param{class}) { + $class = q( class=").html_escape($param{class}).q("); + } + while (($link,$link_name) = splice(@links,0,2)) { + if ($param{links_only}) { + push @return,$link + } + else { + push @return, + qq(). + html_escape($link_name).q(); + } + } + if (wantarray) { + return @return; + } + else { + return join($param{separator},@return); + } } + =head2 maybelink maybelink($in); @@ -393,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; @@ -428,6 +588,8 @@ or submitterurl which returns the URL for each individual address. sub htmlize_addresslinks { my ($prefixfunc, $urlfunc, $addresses,$class) = @_; + carp "htmlize_addresslinks is deprecated"; + $class = defined $class?qq(class="$class" ):''; if (defined $addresses and $addresses ne '') { my @addrs = getparsedaddrs($addresses); @@ -457,116 +619,377 @@ 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); } +=head2 bug_linklist -my $_maintainer; -my $_maintainer_rev; -sub getmaintainers { - return $_maintainer if $_maintainer; - my %maintainer; - my %maintainer_rev; - for my $file (@config{qw(maintainer_file maintainer_file_override)}) { - next unless defined $file; - my $maintfile = new IO::File $file,'r' or - &quitcgi("Unable to open $file: $!"); - while(<$maintfile>) { - next unless m/^(\S+)\s+(\S.*\S)\s*$/; - ($a,$b)=($1,$2); - $a =~ y/A-Z/a-z/; - $maintainer{$a}= $b; - for my $maint (map {lc($_->address)} getparsedaddrs($b)) { - push @{$maintainer_rev{$maint}},$a; - } - } - close($maintfile); - } - $_maintainer = \%maintainer; - $_maintainer_rev = \%maintainer_rev; - return $_maintainer; -} -sub getmaintainers_reverse{ - return $_maintainer_rev if $_maintainer_rev; - getmaintainers(); - return $_maintainer_rev; + bug_linklist($separator,$class,@bugs) + +Creates a set of links to C<@bugs> separated by C<$separator> with +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. + +=cut + + +sub bug_linklist{ + my ($sep,$class,@bugs) = @_; + carp "bug_linklist is deprecated; use bug_links instead"; + return scalar bug_links(bug=>\@bugs,class=>$class,separator=>$sep); } -my $_pseudodesc; -sub getpseudodesc { - return $_pseudodesc if $_pseudodesc; - my %pseudodesc; +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 $pseudo = new IO::File $config{pseudo_desc_file},'r' - or &quitcgi("Unable to open $config{pseudo_desc_file}: $!"); - while(<$pseudo>) { - next unless m/^(\S+)\s+(\S.*\S)\s*$/; - $pseudodesc{lc $1} = $2; - } - close($pseudo); - $_pseudodesc = \%pseudodesc; - return $_pseudodesc; + 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; + } + } } -=head2 bug_links - bug_links($one_bug); - bug_links($starting_bug,$stoping_bugs,); +=head1 Forms + +=cut -Creates a set of links to bugs, starting with bug number -$starting_bug, and finishing with $stoping_bug; if only one bug is -passed, makes a link to only a single bug. +=head2 form_options_and_normal_param -The content of the link is the bug number. + 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. -XXX Use L; we want to be able to support query -arguments here too. =cut -sub bug_links{ - my ($start,$stop,$query_arguments) = @_; - $stop = $stop || $start; - $query_arguments ||= ''; - my @output; - for my $bug ($start..$stop) { - push @output,'$bug); +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 join(', ',@output); + return wantarray?($form_option,$param):$form_option; } -=head2 bug_linklist +=head2 option_form - bug_linklist($separator,$class,@bugs) + print option_form(template=>'pkgreport_options', + param => \%param, + form_options => $form_options, + ) -Creates a set of links to C<@bugs> separated by C<$separator> with -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.] =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 bug_linklist{ - my ($sep,$class,@bugs) = @_; - if (length $class) { - $class = qq(class="$class" ); +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 + +=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; } - return join($sep,map{qq(#$_) - } @bugs); + 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;