X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=Debbugs%2FCGI.pm;h=393b40602ef12203d1c746ddedcb53c0476f3fb3;hb=235a779bdb026b6357e95053e1d7faaab87e8931;hp=4b450de3cf7601fe68e8f9c5060f3eb47246b97e;hpb=f3a25fc7566f8a4a98996a0e01fcb03dc0adf72b;p=debbugs.git diff --git a/Debbugs/CGI.pm b/Debbugs/CGI.pm index 4b450de..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,27 +34,79 @@ 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; + +use Debbugs::Text qw(fill_in_template); + +our %URL_PARAMS = (); + BEGIN{ ($VERSION) = q$Revision: 1.3 $ =~ /^Revision:\s+([^\s+])/; $DEBUG = 0 unless defined $DEBUG; @EXPORT = (); - %EXPORT_TAGS = (url => [qw(bug_url)], - html => [qw(html_escape)], + %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 htmlize_maintlinks), + ], + 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)); + Exporter::export_ok_tags(keys %EXPORT_TAGS); $EXPORT_TAGS{all} = [@EXPORT_OK]; } +=head2 set_url_params + + set_url_params($uri); + + +Sets the url params which will be used to generate urls. + +=cut + +sub set_url_params{ + if (@_ > 1) { + %URL_PARAMS = @_; + } + else { + my $url = Debbugs::URI->new($_[0]||''); + %URL_PARAMS = %{$url->query_form_hash}; + } +} + =head2 bug_url @@ -54,13 +114,122 @@ BEGIN{ 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); + +Munges a url, replacing parameters with %params_to_munge as appropriate. + +=cut + +sub munge_url { + my $url = shift; my %params = @_; - my $url = Debbugs::URI->new('bugreport.cgi?'); - $url->query_form(bug=>$ref,%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 => $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 %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(%params); return $url->as_string; } @@ -75,95 +244,772 @@ Escapes html entities by calling HTML::Entities::encode_entities; sub html_escape{ my ($string) = @_; - return HTML::Entities::encode_entities($string) -} - -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; -# } + return HTML::Entities::encode_entities($string,q(<>&"')); +} + +=head2 cgi_parameters + + cgi_parameters + +Returns all of the cgi_parameters from a CGI script using CGI::Simple + +=cut + +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)]; + } + } + 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}; + } + } + return %param; +} + +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; +} + + +=head1 HTML + +=head2 htmlize_packagelinks + + htmlize_packagelinks + +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. + +=cut + +sub htmlize_packagelinks { + my ($pkgs) = @_; + return '' unless defined $pkgs and $pkgs ne ''; + my @pkglist = splitpackages($pkgs); + + carp "htmlize_packagelinks is deprecated, use package_links instead"; + + return 'Package' . (@pkglist > 1 ? 's' : '') . ': ' . + 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 + + maybelink($in); + maybelink('http://foobarbaz,http://bleh',qr/[, ]+/); + maybelink('http://foobarbaz,http://bleh',qr/[, ]+/,', '); + + +In the first form, links the link if it looks like a link. In the +second form, first splits based on the regex, then reassembles the +link, linking things that look like links. In the third form, rejoins +the split links with commas and spaces. + +=cut + +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; + if (defined $regex) { + @segments = split $regex, $links; + } + else { + @segments = ($links); + } + for my $in (@segments) { + if ($in =~ /^[a-zA-Z0-9+.-]+:/) { # RFC 1738 scheme + push @return, qq{} . html_escape($in) . ''; + } else { + push @return, html_escape($in); + } + } + return @return?join($join,@return):''; +} + + +=head2 htmlize_addresslinks + + htmlize_addresslinks($prefixfunc,$urlfunc,$addresses,$class); + + +Generate a comma-separated list of HTML links to each address given in +$addresses, which should be a comma-separated list of RFC822 +addresses. $urlfunc should be a reference to a function like mainturl +or submitterurl which returns the URL for each individual address. + + +=cut + +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 + { sprintf qq(%s', + $urlfunc->($_->address), + html_escape($_->format) || + '(unknown)' + } @addrs + ); + } + else { + my $prefix = (ref $prefixfunc) ? + $prefixfunc->(1) : $prefixfunc; + return sprintf '%s(unknown)', + $prefix, $urlfunc->(''); + } +} + +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); +} + + +our $_maintainer; +our $_maintainer_rev; + +=head2 bug_linklist + + 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. [Hell, bug_url should be one function with this one +too.] + +=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); +} + + +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; + } +} + + + +=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;