X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=Debbugs%2FCGI.pm;h=0f44943a6bf5c427d44277685f7bc7c08c2321eb;hb=24a595369565410e8302c44fff5d1f2f859d86e9;hp=d51b9be0a469c5503f4e3648964c36bb2bb31e27;hpb=dfffc9e4190838650697c3758a477e92f49939a3;p=debbugs.git

diff --git a/Debbugs/CGI.pm b/Debbugs/CGI.pm
index d51b9be..0f44943 100644
--- a/Debbugs/CGI.pm
+++ b/Debbugs/CGI.pm
@@ -17,8 +17,6 @@ Debbugs::CGI -- General routines for the cgi scripts
 
 use Debbugs::CGI qw(:url :html);
 
-html_escape(bug_url($ref,mbox=>'yes',mboxstatus=>'yes'));
-
 =head1 DESCRIPTION
 
 This module is a replacement for parts of common.pl; subroutines in
@@ -34,7 +32,7 @@ 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;
@@ -49,8 +47,9 @@ use Mail::Address;
 use POSIX qw(ceil);
 use Storable qw(dclone);
 
-use List::Util qw(max);
-
+use List::AllUtils qw(max);
+use File::stat;
+use Digest::MD5 qw(md5_hex);
 use Carp;
 
 use Debbugs::Text qw(fill_in_template);
@@ -63,8 +62,8 @@ BEGIN{
      $DEBUG = 0 unless defined $DEBUG;
 
      @EXPORT = ();
-     %EXPORT_TAGS = (url    => [qw(bug_url bug_links bug_linklist maybelink),
-				qw(set_url_params pkg_url version_url),
+     %EXPORT_TAGS = (url    => [qw(bug_links bug_linklist maybelink),
+				qw(set_url_params version_url),
 				qw(submitterurl mainturl munge_url),
 				qw(package_links bug_links),
 			       ],
@@ -77,6 +76,7 @@ BEGIN{
 		     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 = ();
@@ -106,44 +106,6 @@ sub set_url_params{
 }
 
 
-=head2 bug_url
-
-     bug_url($ref,mbox=>'yes',mboxstat=>'yes');
-
-Constructs urls which point to a specific
-
-XXX use Params::Validate
-
-=cut
-
-sub bug_url{
-     my $ref = shift;
-     my %params;
-     if (@_ % 2) {
-	  shift;
-	  %params = (%URL_PARAMS,@_);
-     }
-     else {
-	  %params = @_;
-     }
-     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);
@@ -161,7 +123,9 @@ sub munge_url {
      while (my ($key,$value) = splice @old_param,0,2) {
 	  push @new_param,($key,$value) unless exists $params{$key};
      }
-     $new_url->query_form(@new_param,%params);
+     $new_url->query_form(@new_param,
+			  map {($_,$params{$_})}
+			  sort keys %params);
      return $new_url->as_string;
 }
 
@@ -288,7 +252,9 @@ sub cgi_parameters {
 
 
 sub quitcgi {
-    my $msg = shift;
+    my ($msg, $status) = @_;
+    $status //= '500 Internal Server Error';
+    print "Status: $status\n";
     print "Content-Type: text/html\n\n";
     print fill_in_template(template=>'cgi/quit',
 			   variables => {msg => $msg}
@@ -618,10 +584,6 @@ sub htmlize_maintlinks {
     return htmlize_addresslinks($prefixfunc, \&mainturl, $maints);
 }
 
-
-our $_maintainer;
-our $_maintainer_rev;
-
 =head2 bug_linklist
 
      bug_linklist($separator,$class,@bugs)
@@ -631,8 +593,7 @@ 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. [Hell, bug_url should be one function with this one
-too.]
+function into one.
 
 =cut
 
@@ -837,7 +798,6 @@ sub option_form{
      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
@@ -934,6 +894,77 @@ sub maint_decode {
      wantarray ? @output : $output[0];
 }
 
+=head1 cache
+
+=head2 calculate_etags
+
+    calculate_etags(files => [qw(list of files)],additional_data => [qw(any additional data)]);
+
+=cut
+
+sub calculate_etags {
+    my %param =
+	validate_with(params => \@_,
+		      spec => {files => {type => ARRAYREF,
+					 default => [],
+					},
+			       additional_data => {type => ARRAYREF,
+						   default => [],
+						  },
+			      },
+		     );
+    my @additional_data = @{$param{additional_data}};
+    for my $file (@{$param{files}}) {
+	my $st = stat($file) or warn "Unable to stat $file: $!";
+	push @additional_data,$st->mtime;
+	push @additional_data,$st->size;
+    }
+    return(md5_hex(join('',sort @additional_data)));
+}
+
+=head2 etag_does_not_match
+
+     etag_does_not_match(cgi=>$q,files=>[qw(list of files)],
+         additional_data=>[qw(any additional data)])
+
+
+Checks to see if the CGI request contains an etag which matches the calculated
+etag.
+
+If there wasn't an etag given, or the etag given doesn't match, return the etag.
+
+If the etag does match, return 0.
+
+=cut
+
+sub etag_does_not_match {
+    my %param =
+	validate_with(params => \@_,
+		      spec => {files => {type => ARRAYREF,
+					 default => [],
+					},
+			       additional_data => {type => ARRAYREF,
+						   default => [],
+						  },
+			       cgi => {type => OBJECT},
+			      },
+		     );
+    my $submitted_etag =
+	$param{cgi}->http('if-none-match');
+    my $etag =
+	calculate_etags(files=>$param{files},
+			additional_data=>$param{additional_data});
+    if (not defined $submitted_etag or
+	length($submitted_etag) != 32
+	or $etag ne $submitted_etag
+       ) {
+	return $etag;
+    }
+    if ($etag eq $submitted_etag) {
+	return 0;
+    }
+}
+
 
 1;