X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=Debbugs%2FCGI.pm;h=393b40602ef12203d1c746ddedcb53c0476f3fb3;hb=235a779bdb026b6357e95053e1d7faaab87e8931;hp=a38a6a79861749a726dd6f3c2f8d5772239eb954;hpb=a54f07e01f95b7ab702a9f08375dc8dad3394ac9;p=debbugs.git diff --git a/Debbugs/CGI.pm b/Debbugs/CGI.pm index a38a6a7..393b406 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; @@ -26,16 +34,29 @@ 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; -use Debbugs::Common qw(); +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::Util qw(max); +use File::stat; +use Digest::MD5 qw(md5_hex); +use Carp; -my %URL_PARAMS = (); +use Debbugs::Text qw(fill_in_template); + +our %URL_PARAMS = (); BEGIN{ @@ -45,15 +66,23 @@ 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), + qw(package_links bug_links), ], html => [qw(html_escape htmlize_bugs htmlize_packagelinks), - qw(maybelink htmlize_addresslinks), + qw(maybelink htmlize_addresslinks htmlize_maintlinks), + ], + util => [qw(cgi_parameters quitcgi), ], - util => [qw(getparsedaddrs)] + 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]; } @@ -99,9 +128,9 @@ sub bug_url{ else { %params = @_; } - my $url = Debbugs::URI->new('bugreport.cgi?'); - $url->query_form(bug=>$ref,%params); - return $url->as_string; + carp "bug_url is deprecated, use bug_links instead"; + + return munge_url('bugreport.cgi?',%params,bug=>$ref); } sub pkg_url{ @@ -113,26 +142,94 @@ sub pkg_url{ else { %params = @_; } - my $url = Debbugs::URI->new('pkgreport.cgi?'); - $url->query_form(%params); - return $url->as_string; + 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); + +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, + map {($_,$params{$_})} + sort keys %params); + return $new_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) = @_; + 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, - ); + $url->query_form(%params); return $url->as_string; } @@ -147,227 +244,66 @@ 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(<>&"')); } -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; -# } - - -# 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. +=head2 cgi_parameters -=cut + cgi_parameters -sub htmlize_bugs{ - my @bugs = @_; - my @html; - - 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; -} +Returns all of the cgi_parameters from a CGI script using CGI::Simple +=cut -sub htmlize_bugstatus { - my %status = %{$_[0]}; - - my $result = ""; - - 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"; +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)]; } } - else { - if (length($status{forwarded})) { - $result .= ";\nForwarded to " - . maybelink($status{forwarded}); + 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}; } - 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"; - } - } + } + return %param; +} - $result .= "."; - return $result; +sub quitcgi { + 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} + ); + exit 0; } -# 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; -} +=head1 HTML =head2 htmlize_packagelinks @@ -375,28 +311,223 @@ sub splitpackages { 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 sub htmlize_packagelinks { - my ($pkgs,$strong) = @_; - return unless defined $pkgs and $pkgs ne ''; + my ($pkgs) = @_; + return '' unless defined $pkgs and $pkgs ne ''; my @pkglist = splitpackages($pkgs); - $strong = 0; - my $openstrong = $strong ? '' : ''; - my $closestrong = $strong ? '' : ''; + carp "htmlize_packagelinks is deprecated, use package_links instead"; return 'Package' . (@pkglist > 1 ? 's' : '') . ': ' . - join(', ', - map { - '' . - $openstrong . html_escape($_) . $closestrong . '' - } @pkglist - ); + package_links(package =>\@pkglist, + class => 'submitter' + ); +} + +=head2 package_links + + join(', ', package_links(packages => \@packages)) + +Given a list of packages, return a list of html which links to the package + +=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; + + +sub package_links { + 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; + } + ); + my %options = %{$param{options}}; + for ((keys %package_search_keys,qw(msg att))) { + delete $options{$_} if exists $options{$_}; + } + my @links = (); + for my $type (qw(src package)) { + push @links, map {my $t_type = $type; + if ($_ =~ s/^src://) { + $t_type = 'src'; + } + (munge_url('pkgreport.cgi?', + %options, + $t_type => $_, + ), + ($t_type eq 'src'?'src:':'').$_); + } make_list($param{$type}) if exists $param{$type}; + } + 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}; + } + 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 bug_links + + join(', ', bug_links(bug => \@packages)) + +Given a list of bugs, return a list of html which links to the bugs + +=over + +=item bug -- arrayref or scalar of bug(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 + +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 @links; + push @links, map {(munge_url('bugreport.cgi?', + %options, + bug => $_, + ), + $_); + } 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 @@ -414,6 +545,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; @@ -449,19 +585,22 @@ 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); my $prefix = (ref $prefixfunc) ? $prefixfunc->(scalar @addrs):$prefixfunc; return $prefix . - join ', ', map + join(', ', map { sprintf qq(%s', $urlfunc->($_->address), html_escape($_->format) || '(unknown)' - } @addrs; + } @addrs + ); } else { my $prefix = (ref $prefixfunc) ? @@ -471,44 +610,23 @@ sub htmlize_addresslinks { } } - - -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 emailfromrfc822{ + my $addr = getparsedaddrs($_[0] || ""); + $addr = defined $addr?$addr->address:''; + return $addr; } +sub mainturl { package_links(maint => $_[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_links - - bug_links($one_bug); - bug_links($starting_bug,$stoping_bugs,); - -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. - -The content of the link is the bug number. - -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); - } - return join(', ',@output); -} +our $_maintainer; +our $_maintainer_rev; =head2 bug_linklist @@ -527,16 +645,372 @@ too.] sub bug_linklist{ my ($sep,$class,@bugs) = @_; - if (length $class) { - $class = qq(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 + my $o_key = $key; + 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 + } + # 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, + }, + ); +} + +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; } - return join($sep,map{qq(#$_) - } @bugs); } +=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]; +} + +=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;