+++ /dev/null
-# 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 <don@donarmstrong.com>.
-
-package Debbugs::CGI;
-
-=head1 NAME
-
-Debbugs::CGI -- General routines for the cgi scripts
-
-=head1 SYNOPSIS
-
-use Debbugs::CGI qw(:url :html);
-
-=head1 DESCRIPTION
-
-This module is a replacement for parts of common.pl; subroutines in
-common.pl will be gradually phased out and replaced with equivalent
-(or better) functionality here.
-
-=head1 BUGS
-
-None known.
-
-=cut
-
-use warnings;
-use strict;
-use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
-use Exporter qw(import);
-
-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_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),
- ],
- 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(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 Scalar::Util qw(looks_like_number);
-
-use List::AllUtils qw(max);
-use File::stat;
-use Digest::MD5 qw(md5_hex);
-use Carp;
-
-use Debbugs::Text qw(fill_in_template);
-
-
-
-=head2 set_url_params
-
- 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 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 => $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 format -- optional image format override
-
-=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 => [],
- },
- format => {type => SCALAR,
- optional => 1,
- },
- 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;
-}
-
-=head2 html_escape
-
- html_escape($string)
-
-Escapes html entities by calling HTML::Entities::encode_entities;
-
-=cut
-
-sub html_escape{
- my ($string) = @_;
-
- 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<Debbugs::CGI/splitpackages> 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;
-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(<a$class href=").
- html_escape($link).q(">).
- html_escape($link_name).q(</a>);
- }
- }
- 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 {
- state $spec = {bug => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- links_only => {type => BOOLEAN,
- default => 0,
- },
- class => {type => SCALAR,
- default => '',
- },
- separator => {type => SCALAR,
- default => ', ',
- },
- options => {type => HASHREF,
- default => {},
- },
- };
- my %param = validate_with(params => \@_,
- spec => $spec,
- );
- 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 {my $b = ceil($_);
- ('bugreport.cgi?bug='.$b,
- $b)}
- grep {looks_like_number($_)}
- make_list($param{bug}) if exists $param{bug};
- }
- my @return;
- my ($link,$link_name);
- my $class = '';
- 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(<a$class href=").
- html_escape($link).q(">).
- html_escape($link_name).q(</a>);
- }
- }
- 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(<a href=").html_escape($2).q(">).html_escape($2).q(</a>):'').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{<a href="$in">} . html_escape($in) . '</a>';
- } 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(<a ${class}).
- 'href="%s">%s</a>',
- $urlfunc->($_->address),
- html_escape($_->format) ||
- '(unknown)'
- } @addrs
- );
- }
- else {
- my $prefix = (ref $prefixfunc) ?
- $prefixfunc->(1) : $prefixfunc;
- return sprintf '%s<a '.$class.'href="%s">(unknown)</a>',
- $prefix, $urlfunc->('');
- }
-}
-
-sub emailfromrfc822{
- my $addr = getparsedaddrs($_[0] || "");
- $addr = defined $addr?$addr->address:'';
- return $addr;
-}
-
-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
-
- 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<Params::Validate>; 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);
-}
-
-
-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
-
- <input type="hidden" name="_fo_combine_key_fo_searchkey_value_fo_searchvalue" value="1">
-
-which would combine the _fo_searchkey and _fo_searchvalue input fields, so
-
- <input type="text" name="_fo_searchkey" value="foo">
- <input type="text" name="_fo_searchvalue" value="bar">
-
-would yield foo=>'bar' in %param.
-
-=head3 concatenate
-
-Concatenate concatenates values into a single entry in a parameter
-
-For example, you would have
-
- <input type="hidden" name="_fo_concatentate_into_foo_with_:_fo_blah_fo_bleargh" value="1">
-
-which would combine the _fo_searchkey and _fo_searchvalue input fields, so
-
- <input type="text" name="_fo_blah" value="bar">
- <input type="text" name="_fo_bleargh" value="baz">
-
-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
-
-=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;
-
-
-__END__
-
-
-
-
-
-
projects / debbugs.git / blobdiff