Debbugs/CGI.pm

   1 # This module is part of debbugs, and is released
   2 # under the terms of the GPL version 2, or any later
   3 # version at your option.
   4 # See the file README and COPYING for more information.
   5 #
   6 # [Other people have contributed to this file; their copyrights should
   7 # go here too.]
   8 # Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
   9
  10 package Debbugs::CGI;
  11
  12 =head1 NAME
  13
  14 Debbugs::CGI -- General routines for the cgi scripts
  15
  16 =head1 SYNOPSIS
  17
  18 use Debbugs::CGI qw(:url :html);
  19
  20 =head1 DESCRIPTION
  21
  22 This module is a replacement for parts of common.pl; subroutines in
  23 common.pl will be gradually phased out and replaced with equivalent
  24 (or better) functionality here.
  25
  26 =head1 BUGS
  27
  28 None known.
  29
  30 =cut
  31
  32 use warnings;
  33 use strict;
  34 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
  35 use Exporter qw(import);
  36
  37 use feature qw(state);
  38
  39 our %URL_PARAMS = ();
  40
  41 BEGIN{
  42      ($VERSION) = q$Revision: 1.3 $ =~ /^Revision:\s+([^\s+])/;
  43      $DEBUG = 0 unless defined $DEBUG;
  44
  45      @EXPORT = ();
  46      %EXPORT_TAGS = (url    => [qw(bug_links bug_linklist maybelink),
  47                                 qw(set_url_params version_url),
  48                                 qw(submitterurl mainturl munge_url),
  49                                 qw(package_links bug_links),
  50                                ],
  51                      html   => [qw(html_escape htmlize_bugs htmlize_packagelinks),
  52                                 qw(maybelink htmlize_addresslinks htmlize_maintlinks),
  53                                ],
  54                      util   => [qw(cgi_parameters quitcgi),
  55                                ],
  56                      forms  => [qw(option_form form_options_and_normal_param)],
  57                      usertags => [qw(add_user)],
  58                      misc   => [qw(maint_decode)],
  59                      package_search => [qw(@package_search_key_order %package_search_keys)],
  60                      cache => [qw(calculate_etag etag_does_not_match)],
  61                      #status => [qw(getbugstatus)],
  62                     );
  63      @EXPORT_OK = ();
  64      Exporter::export_ok_tags(keys %EXPORT_TAGS);
  65      $EXPORT_TAGS{all} = [@EXPORT_OK];
  66 }
  67
  68 use Debbugs::URI;
  69 use URI::Escape;
  70 use HTML::Entities;
  71 use Debbugs::Common qw(getparsedaddrs make_list);
  72 use Params::Validate qw(validate_with :types);
  73
  74 use Debbugs::Config qw(:config);
  75 use Debbugs::Status qw(splitpackages isstrongseverity);
  76 use Debbugs::User qw();
  77
  78 use Mail::Address;
  79 use POSIX qw(ceil);
  80 use Storable qw(dclone);
  81
  82 use List::AllUtils qw(max);
  83 use File::stat;
  84 use Digest::MD5 qw(md5_hex);
  85 use Carp;
  86
  87 use Debbugs::Text qw(fill_in_template);
  88
  89
  90
  91 =head2 set_url_params
  92
  93      set_url_params($uri);
  94
  95
  96 Sets the url params which will be used to generate urls.
  97
  98 =cut
  99
 100 sub set_url_params{
 101      if (@_ > 1) {
 102           %URL_PARAMS = @_;
 103      }
 104      else {
 105           my $url = Debbugs::URI->new($_[0]||'');
 106           %URL_PARAMS = %{$url->query_form_hash};
 107      }
 108 }
 109
 110
 111 =head2 munge_url
 112
 113      my $url = munge_url($url,%params_to_munge);
 114
 115 Munges a url, replacing parameters with %params_to_munge as appropriate.
 116
 117 =cut
 118
 119 sub munge_url {
 120      my $url = shift;
 121      my %params = @_;
 122      my $new_url = Debbugs::URI->new($url);
 123      my @old_param = $new_url->query_form();
 124      my @new_param;
 125      while (my ($key,$value) = splice @old_param,0,2) {
 126           push @new_param,($key,$value) unless exists $params{$key};
 127      }
 128      $new_url->query_form(@new_param,
 129                           map {($_,$params{$_})}
 130                           sort keys %params);
 131      return $new_url->as_string;
 132 }
 133
 134
 135 =head2 version_url
 136
 137      version_url(package => $package,found => $found,fixed => $fixed)
 138
 139 Creates a link to the version cgi script
 140
 141 =over
 142
 143 =item package -- source package whose graph to display
 144
 145 =item found -- arrayref of found versions
 146
 147 =item fixed -- arrayref of fixed versions
 148
 149 =item width -- optional width of graph
 150
 151 =item height -- optional height of graph
 152
 153 =item info -- display html info surrounding graph; defaults to 1 if
 154 width and height are not passed.
 155
 156 =item collapse -- whether to collapse the graph; defaults to 1 if
 157 width and height are passed.
 158
 159 =back
 160
 161 =cut
 162
 163 sub version_url{
 164      my %params = validate_with(params => \@_,
 165                                 spec   => {package => {type => SCALAR|ARRAYREF,
 166                                                       },
 167                                            found   => {type => ARRAYREF,
 168                                                        default => [],
 169                                                       },
 170                                            fixed   => {type => ARRAYREF,
 171                                                        default => [],
 172                                                       },
 173                                            width   => {type => SCALAR,
 174                                                        optional => 1,
 175                                                       },
 176                                            height  => {type => SCALAR,
 177                                                        optional => 1,
 178                                                       },
 179                                            absolute => {type => BOOLEAN,
 180                                                         default => 0,
 181                                                        },
 182                                            collapse => {type => BOOLEAN,
 183                                                         default => 1,
 184                                                        },
 185                                            info     => {type => BOOLEAN,
 186                                                         optional => 1,
 187                                                        },
 188                                           }
 189                                );
 190      if (not defined $params{width} and not defined $params{height}) {
 191           $params{info} = 1 if not exists $params{info};
 192      }
 193      my $url = Debbugs::URI->new('version.cgi?');
 194      $url->query_form(%params);
 195      return $url->as_string;
 196 }
 197
 198 =head2 html_escape
 199
 200      html_escape($string)
 201
 202 Escapes html entities by calling HTML::Entities::encode_entities;
 203
 204 =cut
 205
 206 sub html_escape{
 207      my ($string) = @_;
 208
 209      return HTML::Entities::encode_entities($string,q(<>&"'));
 210 }
 211
 212 =head2 cgi_parameters
 213
 214      cgi_parameters
 215
 216 Returns all of the cgi_parameters from a CGI script using CGI::Simple
 217
 218 =cut
 219
 220 sub cgi_parameters {
 221      my %options = validate_with(params => \@_,
 222                                  spec   => {query   => {type => OBJECT,
 223                                                         can  => 'param',
 224                                                        },
 225                                             single  => {type => ARRAYREF,
 226                                                         default => [],
 227                                                        },
 228                                             default => {type => HASHREF,
 229                                                         default => {},
 230                                                        },
 231                                            },
 232                                 );
 233      my $q = $options{query};
 234      my %single;
 235      @single{@{$options{single}}} = (1) x @{$options{single}};
 236      my %param;
 237      for my $paramname ($q->param) {
 238           if ($single{$paramname}) {
 239                $param{$paramname} = $q->param($paramname);
 240           }
 241           else {
 242                $param{$paramname} = [$q->param($paramname)];
 243           }
 244      }
 245      for my $default (keys %{$options{default}}) {
 246           if (not exists $param{$default}) {
 247                # We'll clone the reference here to avoid surprises later.
 248                $param{$default} = ref($options{default}{$default})?
 249                     dclone($options{default}{$default}):$options{default}{$default};
 250           }
 251      }
 252      return %param;
 253 }
 254
 255
 256 sub quitcgi {
 257     my ($msg, $status) = @_;
 258     $status //= '500 Internal Server Error';
 259     print "Status: $status\n";
 260     print "Content-Type: text/html\n\n";
 261     print fill_in_template(template=>'cgi/quit',
 262                            variables => {msg => $msg}
 263                           );
 264     exit 0;
 265 }
 266
 267
 268 =head1 HTML
 269
 270 =head2 htmlize_packagelinks
 271
 272      htmlize_packagelinks
 273
 274 Given a scalar containing a list of packages separated by something
 275 that L<Debbugs::CGI/splitpackages> can separate, returns a
 276 formatted set of links to packages in html.
 277
 278 =cut
 279
 280 sub htmlize_packagelinks {
 281     my ($pkgs) = @_;
 282     return '' unless defined $pkgs and $pkgs ne '';
 283     my @pkglist = splitpackages($pkgs);
 284
 285     carp "htmlize_packagelinks is deprecated, use package_links instead";
 286
 287     return 'Package' . (@pkglist > 1 ? 's' : '') . ': ' .
 288            package_links(package =>\@pkglist,
 289                          class   => 'submitter'
 290                         );
 291 }
 292
 293 =head2 package_links
 294
 295      join(', ', package_links(packages => \@packages))
 296
 297 Given a list of packages, return a list of html which links to the package
 298
 299 =over
 300
 301 =item package -- arrayref or scalar of package(s)
 302
 303 =item submitter -- arrayref or scalar of submitter(s)
 304
 305 =item src -- arrayref or scalar of source(s)
 306
 307 =item maintainer -- arrayref or scalar of maintainer(s)
 308
 309 =item links_only -- return only links, not htmlized links, defaults to
 310 returning htmlized links.
 311
 312 =item class -- class of the a href, defaults to ''
 313
 314 =back
 315
 316 =cut
 317
 318 our @package_search_key_order = (package   => 'in package',
 319                                  tag       => 'tagged',
 320                                  severity  => 'with severity',
 321                                  src       => 'in source package',
 322                                  maint     => 'in packages maintained by',
 323                                  submitter => 'submitted by',
 324                                  owner     => 'owned by',
 325                                  status    => 'with status',
 326                                  affects   => 'which affect package',
 327                                  correspondent => 'with mail from',
 328                                  newest        => 'newest bugs',
 329                                  bugs          => 'in bug',
 330                                 );
 331 our %package_search_keys = @package_search_key_order;
 332 our %package_links_invalid_options =
 333     map {($_,1)} (keys %package_search_keys,
 334                   qw(msg att));
 335
 336 sub package_links {
 337      state $spec =
 338         {(map { ($_,{type => SCALAR|ARRAYREF,
 339                      optional => 1,
 340                     });
 341             } keys %package_search_keys,
 342           ## these are aliases for package
 343           ## search keys
 344           source => {type => SCALAR|ARRAYREF,
 345                      optional => 1,
 346                     },
 347           maintainer => {type => SCALAR|ARRAYREF,
 348                          optional => 1,
 349                         },
 350          ),
 351          links_only => {type => BOOLEAN,
 352                         default => 0,
 353                        },
 354          class => {type => SCALAR,
 355                    default => '',
 356                   },
 357          separator => {type => SCALAR,
 358                        default => ', ',
 359                       },
 360          options => {type => HASHREF,
 361                      default => {},
 362                     },
 363         };
 364      my %param = validate_with(params => \@_,
 365                                spec   => $spec,
 366                               );
 367      my %options = %{$param{options}};
 368      for (grep {$package_links_invalid_options{$_}} keys %options) {
 369          delete $options{$_};
 370      }
 371      ## remove aliases for source and maintainer
 372      if (exists $param{source}) {
 373          $param{src} = [exists $param{src}?make_list($param{src}):(),
 374                         make_list($param{source}),
 375                        ];
 376          delete $param{source};
 377      }
 378      if (exists $param{maintainer}) {
 379          $param{maint} = [exists $param{maint}?make_list($param{maint}):(),
 380                           make_list($param{maintainer}),
 381                          ];
 382          delete $param{maintainer};
 383      }
 384      my $has_options = keys %options;
 385      my @links = ();
 386      for my $type (qw(src package)) {
 387          next unless exists $param{$type};
 388          for my $target (make_list($param{$type})) {
 389              my $t_type = $type;
 390              if ($target =~ s/^src://) {
 391                  $t_type = 'source';
 392              } elsif ($t_type eq 'source') {
 393                  $target = 'src:'.$target;
 394              }
 395              if ($has_options) {
 396                  push @links,
 397                      (munge_url('pkgreport.cgi?',
 398                                %options,
 399                                $t_type => $target,
 400                                ),
 401                       $target);
 402              } else {
 403                  push @links,
 404                      ('pkgreport.cgi?'.$t_type.'='.uri_escape_utf8($target),
 405                       $target);
 406              }
 407          }
 408      }
 409      for my $type (qw(maint owner submitter correspondent)) {
 410          next unless exists $param{$type};
 411          for my $target (make_list($param{$type})) {
 412              my $addr = getparsedaddrs($target);
 413              $addr = defined $addr?$addr->address:'';
 414              if ($has_options) {
 415                  push @links,
 416                      (munge_url('pkgreport.cgi?',
 417                                 %options,
 418                                 $type => $target),
 419                       $target);
 420              } else {
 421                  push @links,
 422                      ('pkgreport.cgi?'.
 423                       $type.'='.uri_escape_utf8($target),
 424                       $target);
 425              }
 426          }
 427      }
 428      my @return = ();
 429      my ($link,$link_name);
 430      my $class = '';
 431      if (length $param{class}) {
 432           $class = q( class=").html_escape($param{class}).q(");
 433      }
 434      while (($link,$link_name) = splice(@links,0,2)) {
 435           if ($param{links_only}) {
 436                push @return,$link
 437           }
 438           else {
 439                push @return,
 440                     qq(<a$class href=").
 441                          html_escape($link).q(">).
 442                               html_escape($link_name).q(</a>);
 443           }
 444      }
 445      if (wantarray) {
 446           return @return;
 447      }
 448      else {
 449           return join($param{separator},@return);
 450      }
 451 }
 452
 453 =head2 bug_links
 454
 455      join(', ', bug_links(bug => \@packages))
 456
 457 Given a list of bugs, return a list of html which links to the bugs
 458
 459 =over
 460
 461 =item bug -- arrayref or scalar of bug(s)
 462
 463 =item links_only -- return only links, not htmlized links, defaults to
 464 returning htmlized links.
 465
 466 =item class -- class of the a href, defaults to ''
 467
 468 =back
 469
 470 =cut
 471
 472 sub bug_links {
 473      my %param = validate_with(params => \@_,
 474                                spec   => {bug => {type => SCALAR|ARRAYREF,
 475                                                   optional => 1,
 476                                                  },
 477                                           links_only => {type => BOOLEAN,
 478                                                          default => 0,
 479                                                         },
 480                                           class => {type => SCALAR,
 481                                                     default => '',
 482                                                    },
 483                                           separator => {type => SCALAR,
 484                                                         default => ', ',
 485                                                        },
 486                                           options => {type => HASHREF,
 487                                                       default => {},
 488                                                      },
 489                                          },
 490                               );
 491      my %options = %{$param{options}};
 492
 493      for (qw(bug)) {
 494           delete $options{$_} if exists $options{$_};
 495      }
 496      my $has_options = keys %options;
 497      my @links;
 498      if ($has_options) {
 499          push @links, map {(munge_url('bugreport.cgi?',
 500                                       %options,
 501                                       bug => $_,
 502                                      ),
 503                             $_);
 504                        } make_list($param{bug}) if exists $param{bug};
 505      } else {
 506          push @links, map {('bugreport.cgi?bug='.uri_escape_utf8($_),
 507                             $_)}
 508              make_list($param{bug}) if exists $param{bug};
 509      }
 510      my @return;
 511      my ($link,$link_name);
 512      my $class = '';
 513      if (length $param{class}) {
 514           $class = q( class=").html_escape($param{class}).q(");
 515      }
 516      while (($link,$link_name) = splice(@links,0,2)) {
 517           if ($param{links_only}) {
 518                push @return,$link
 519           }
 520           else {
 521                push @return,
 522                     qq(<a$class href=").
 523                          html_escape($link).q(">).
 524                               html_escape($link_name).q(</a>);
 525           }
 526      }
 527      if (wantarray) {
 528           return @return;
 529      }
 530      else {
 531           return join($param{separator},@return);
 532      }
 533 }
 534
 535
 536
 537 =head2 maybelink
 538
 539      maybelink($in);
 540      maybelink('http://foobarbaz,http://bleh',qr/[, ]+/);
 541      maybelink('http://foobarbaz,http://bleh',qr/[, ]+/,', ');
 542
 543
 544 In the first form, links the link if it looks like a link. In the
 545 second form, first splits based on the regex, then reassembles the
 546 link, linking things that look like links. In the third form, rejoins
 547 the split links with commas and spaces.
 548
 549 =cut
 550
 551 sub maybelink {
 552     my ($links,$regex,$join) = @_;
 553     if (not defined $regex and not defined $join) {
 554          $links =~ s{(.*?)((?:(?:ftp|http|https)://[\S~-]+?/?)?)([\)\'\:\.\,]?(?:\s|\.<|$))}
 555                     {html_escape($1).(length $2?q(<a href=").html_escape($2).q(">).html_escape($2).q(</a>):'').html_escape($3)}geimo;
 556          return $links;
 557     }
 558     $join = ' ' if not defined $join;
 559     my @return;
 560     my @segments;
 561     if (defined $regex) {
 562          @segments = split $regex, $links;
 563     }
 564     else {
 565          @segments = ($links);
 566     }
 567     for my $in (@segments) {
 568          if ($in =~ /^[a-zA-Z0-9+.-]+:/) { # RFC 1738 scheme
 569               push @return, qq{<a href="$in">} . html_escape($in) . '</a>';
 570          } else {
 571               push @return, html_escape($in);
 572          }
 573     }
 574     return @return?join($join,@return):'';
 575 }
 576
 577
 578 =head2 htmlize_addresslinks
 579
 580      htmlize_addresslinks($prefixfunc,$urlfunc,$addresses,$class);
 581
 582
 583 Generate a comma-separated list of HTML links to each address given in
 584 $addresses, which should be a comma-separated list of RFC822
 585 addresses. $urlfunc should be a reference to a function like mainturl
 586 or submitterurl which returns the URL for each individual address.
 587
 588
 589 =cut
 590
 591 sub htmlize_addresslinks {
 592      my ($prefixfunc, $urlfunc, $addresses,$class) = @_;
 593      carp "htmlize_addresslinks is deprecated";
 594
 595      $class = defined $class?qq(class="$class" ):'';
 596      if (defined $addresses and $addresses ne '') {
 597           my @addrs = getparsedaddrs($addresses);
 598           my $prefix = (ref $prefixfunc) ?
 599                $prefixfunc->(scalar @addrs):$prefixfunc;
 600           return $prefix .
 601                join(', ', map
 602                     { sprintf qq(<a ${class}).
 603                            'href="%s">%s</a>',
 604                                 $urlfunc->($_->address),
 605                                      html_escape($_->format) ||
 606                                           '(unknown)'
 607                                      } @addrs
 608                    );
 609      }
 610      else {
 611           my $prefix = (ref $prefixfunc) ?
 612                $prefixfunc->(1) : $prefixfunc;
 613           return sprintf '%s<a '.$class.'href="%s">(unknown)</a>',
 614                $prefix, $urlfunc->('');
 615      }
 616 }
 617
 618 sub emailfromrfc822{
 619      my $addr = getparsedaddrs($_[0] || "");
 620      $addr = defined $addr?$addr->address:'';
 621      return $addr;
 622 }
 623
 624 sub mainturl { package_links(maintainer => $_[0], links_only => 1); }
 625 sub submitterurl { package_links(submitter => $_[0], links_only => 1); }
 626 sub htmlize_maintlinks {
 627     my ($prefixfunc, $maints) = @_;
 628     carp "htmlize_maintlinks is deprecated";
 629     return htmlize_addresslinks($prefixfunc, \&mainturl, $maints);
 630 }
 631
 632 =head2 bug_linklist
 633
 634      bug_linklist($separator,$class,@bugs)
 635
 636 Creates a set of links to C<@bugs> separated by C<$separator> with
 637 link class C<$class>.
 638
 639 XXX Use L<Params::Validate>; we want to be able to support query
 640 arguments here too; we should be able to combine bug_links and this
 641 function into one.
 642
 643 =cut
 644
 645
 646 sub bug_linklist{
 647      my ($sep,$class,@bugs) = @_;
 648      carp "bug_linklist is deprecated; use bug_links instead";
 649      return scalar bug_links(bug=>\@bugs,class=>$class,separator=>$sep);
 650 }
 651
 652
 653 sub add_user {
 654      my ($user,$usertags,$bug_usertags,$seen_users,$cats,$hidden) = @_;
 655      $seen_users = {} if not defined $seen_users;
 656      $bug_usertags = {} if not defined $bug_usertags;
 657      $usertags = {} if not defined $usertags;
 658      $cats = {} if not defined $cats;
 659      $hidden = {} if not defined $hidden;
 660      return if exists $seen_users->{$user};
 661      $seen_users->{$user} = 1;
 662
 663      my $u = Debbugs::User::get_user($user);
 664
 665      my %vis = map { $_, 1 } @{$u->{"visible_cats"}};
 666      for my $c (keys %{$u->{"categories"}}) {
 667           $cats->{$c} = $u->{"categories"}->{$c};
 668           $hidden->{$c} = 1 unless defined $vis{$c};
 669      }
 670      for my $t (keys %{$u->{"tags"}}) {
 671           $usertags->{$t} = [] unless defined $usertags->{$t};
 672           push @{$usertags->{$t}}, @{$u->{"tags"}->{$t}};
 673      }
 674
 675      %{$bug_usertags} = ();
 676      for my $t (keys %{$usertags}) {
 677           for my $b (@{$usertags->{$t}}) {
 678                $bug_usertags->{$b} = [] unless defined $bug_usertags->{$b};
 679                push @{$bug_usertags->{$b}}, $t;
 680           }
 681      }
 682 }
 683
 684
 685
 686 =head1 Forms
 687
 688 =cut
 689
 690 =head2 form_options_and_normal_param
 691
 692      my ($form_option,$param) = form_options_and_normal_param(\%param)
 693            if $param{form_options};
 694      my $form_option = form_options_and_normal_param(\%param)
 695            if $param{form_options};
 696
 697 Translates from special form_options to a set of parameters which can
 698 be used to run the current page.
 699
 700 The idea behind this is to allow complex forms to relatively easily
 701 cause options that the existing cgi scripts understand to be set.
 702
 703 Currently there are two commands which are understood:
 704 combine, and concatenate.
 705
 706 =head3 combine
 707
 708 Combine works by entering key,value pairs into the parameters using
 709 the key field option input field, and the value field option input
 710 field.
 711
 712 For example, you would have
 713
 714  <input type="hidden" name="_fo_combine_key_fo_searchkey_value_fo_searchvalue" value="1">
 715
 716 which would combine the _fo_searchkey and _fo_searchvalue input fields, so
 717
 718  <input type="text" name="_fo_searchkey" value="foo">
 719  <input type="text" name="_fo_searchvalue" value="bar">
 720
 721 would yield foo=>'bar' in %param.
 722
 723 =head3 concatenate
 724
 725 Concatenate concatenates values into a single entry in a parameter
 726
 727 For example, you would have
 728
 729  <input type="hidden" name="_fo_concatentate_into_foo_with_:_fo_blah_fo_bleargh" value="1">
 730
 731 which would combine the _fo_searchkey and _fo_searchvalue input fields, so
 732
 733  <input type="text" name="_fo_blah" value="bar">
 734  <input type="text" name="_fo_bleargh" value="baz">
 735
 736 would yield foo=>'bar:baz' in %param.
 737
 738
 739 =cut
 740
 741 my $form_option_leader = '_fo_';
 742 sub form_options_and_normal_param{
 743      my ($orig_param) = @_;
 744      # all form_option parameters start with _fo_
 745      my ($param,$form_option) = ({},{});
 746      for my $key (keys %{$orig_param}) {
 747           if ($key =~ /^\Q$form_option_leader\E/) {
 748                $form_option->{$key} = $orig_param->{$key};
 749           }
 750           else {
 751                $param->{$key} = $orig_param->{$key};
 752           }
 753      }
 754      # at this point, we check for commands
 755  COMMAND: for my $key (keys %{$form_option}) {
 756           $key =~ s/^\Q$form_option_leader\E//;
 757           if (my ($key_name,$value_name) =
 758               $key =~ /combine_key(\Q$form_option_leader\E.+)
 759               _value(\Q$form_option_leader\E.+)$/x
 760              ) {
 761                next unless defined $form_option->{$key_name};
 762                next unless defined $form_option->{$value_name};
 763                my @keys = make_list($form_option->{$key_name});
 764                my @values = make_list($form_option->{$value_name});
 765                for my $i (0 .. $#keys) {
 766                     last if $i > $#values;
 767                     next if not defined $keys[$i];
 768                     next if not defined $values[$i];
 769                     __add_to_param($param,
 770                                    $keys[$i],
 771                                    $values[$i],
 772                                   );
 773                }
 774           }
 775           elsif (my ($field,$concatenate_key,$fields) =
 776                  $key =~ /concatenate_into_(.+?)((?:_with_[^_])?)
 777                           ((?:\Q$form_option_leader\E.+?)+)
 778                           $/x
 779                 ) {
 780                if (length $concatenate_key) {
 781                     $concatenate_key =~ s/_with_//;
 782                }
 783                else {
 784                     $concatenate_key = ':';
 785                }
 786                my @fields = $fields =~ m/(\Q$form_option_leader\E.+?)(?:(?=\Q$form_option_leader\E)|$)/g;
 787                my %field_list;
 788                my $max_num = 0;
 789                for my $f (@fields) {
 790                     next COMMAND unless defined $form_option->{$f};
 791                     $field_list{$f} = [make_list($form_option->{$f})];
 792                     $max_num = max($max_num,$#{$field_list{$f}});
 793                }
 794                for my $i (0 .. $max_num) {
 795                     next unless @fields == grep {$i <= $#{$field_list{$_}} and
 796                                                       defined $field_list{$_}[$i]} @fields;
 797                     __add_to_param($param,
 798                                    $field,
 799                                    join($concatenate_key,
 800                                         map {$field_list{$_}[$i]} @fields
 801                                        )
 802                                   );
 803                }
 804           }
 805      }
 806      return wantarray?($form_option,$param):$form_option;
 807 }
 808
 809 =head2 option_form
 810
 811      print option_form(template=>'pkgreport_options',
 812                        param   => \%param,
 813                        form_options => $form_options,
 814                       )
 815
 816
 817
 818 =cut
 819
 820 sub option_form{
 821      my %param = validate_with(params => \@_,
 822                                spec   => {template => {type => SCALAR,
 823                                                       },
 824                                           variables => {type => HASHREF,
 825                                                         default => {},
 826                                                        },
 827                                           language => {type => SCALAR,
 828                                                        optional => 1,
 829                                                       },
 830                                           param => {type => HASHREF,
 831                                                     default => {},
 832                                                    },
 833                                           form_options => {type => HASHREF,
 834                                                            default => {},
 835                                                           },
 836                                          },
 837                               );
 838
 839      # First, we need to see if we need to add particular types of
 840      # parameters
 841      my $variables = dclone($param{variables});
 842      $variables->{param} = dclone($param{param});
 843      for my $key (keys %{$param{form_option}}) {
 844           # strip out leader; shouldn't be anything here without one,
 845           # but skip stupid things anyway
 846           next unless $key =~ s/^\Q$form_option_leader\E//;
 847           if ($key =~ /^add_(.+)$/) {
 848                # this causes a specific parameter to be added
 849                __add_to_param($variables->{param},
 850                               $1,
 851                               ''
 852                              );
 853           }
 854           elsif ($key =~ /^delete_(.+?)(?:_(\d+))?$/) {
 855                next unless exists $variables->{param}{$1};
 856                if (ref $variables->{param}{$1} eq 'ARRAY' and
 857                    defined $2 and
 858                    defined $variables->{param}{$1}[$2]
 859                   ) {
 860                     splice @{$variables->{param}{$1}},$2,1;
 861                }
 862                else {
 863                     delete $variables->{param}{$1};
 864                }
 865           }
 866           # we'll add extra comands here once I figure out what they
 867           # should be
 868      }
 869      # now at this point, we're ready to create the template
 870      return Debbugs::Text::fill_in_template(template=>$param{template},
 871                                             (exists $param{language}?(language=>$param{language}):()),
 872                                             variables => $variables,
 873                                             hole_var  => {'&html_escape' => \&html_escape,
 874                                                          },
 875                                            );
 876 }
 877
 878 sub __add_to_param{
 879      my ($param,$key,@values) = @_;
 880
 881      if (exists $param->{$key} and not
 882          ref $param->{$key}) {
 883           @{$param->{$key}} = [$param->{$key},
 884                                @values
 885                               ];
 886      }
 887      else {
 888           push @{$param->{$key}}, @values;
 889      }
 890 }
 891
 892
 893
 894 =head1 misc
 895
 896 =cut
 897
 898 =head2 maint_decode
 899
 900      maint_decode
 901
 902 Decodes the funky maintainer encoding.
 903
 904 Don't ask me what in the world it does.
 905
 906 =cut
 907
 908 sub maint_decode {
 909      my @input = @_;
 910      return () unless @input;
 911      my @output;
 912      for my $input (@input) {
 913           my $decoded = $input;
 914           $decoded =~ s/-([^_]+)/-$1_-/g;
 915           $decoded =~ s/_/-20_/g;
 916           $decoded =~ s/^,(.*),(.*),([^,]+)$/$1-40_$2-20_-28_$3-29_/;
 917           $decoded =~ s/^([^,]+),(.*),(.*),/$1-20_-3c_$2-40_$3-3e_/;
 918           $decoded =~ s/\./-2e_/g;
 919           $decoded =~ s/-([0-9a-f]{2})_/pack('H*',$1)/ge;
 920           push @output,$decoded;
 921      }
 922      wantarray ? @output : $output[0];
 923 }
 924
 925 =head1 cache
 926
 927 =head2 calculate_etags
 928
 929     calculate_etags(files => [qw(list of files)],additional_data => [qw(any additional data)]);
 930
 931 =cut
 932
 933 sub calculate_etags {
 934     my %param =
 935         validate_with(params => \@_,
 936                       spec => {files => {type => ARRAYREF,
 937                                          default => [],
 938                                         },
 939                                additional_data => {type => ARRAYREF,
 940                                                    default => [],
 941                                                   },
 942                               },
 943                      );
 944     my @additional_data = @{$param{additional_data}};
 945     for my $file (@{$param{files}}) {
 946         my $st = stat($file) or warn "Unable to stat $file: $!";
 947         push @additional_data,$st->mtime;
 948         push @additional_data,$st->size;
 949     }
 950     return(md5_hex(join('',sort @additional_data)));
 951 }
 952
 953 =head2 etag_does_not_match
 954
 955      etag_does_not_match(cgi=>$q,files=>[qw(list of files)],
 956          additional_data=>[qw(any additional data)])
 957
 958
 959 Checks to see if the CGI request contains an etag which matches the calculated
 960 etag.
 961
 962 If there wasn't an etag given, or the etag given doesn't match, return the etag.
 963
 964 If the etag does match, return 0.
 965
 966 =cut
 967
 968 sub etag_does_not_match {
 969     my %param =
 970         validate_with(params => \@_,
 971                       spec => {files => {type => ARRAYREF,
 972                                          default => [],
 973                                         },
 974                                additional_data => {type => ARRAYREF,
 975                                                    default => [],
 976                                                   },
 977                                cgi => {type => OBJECT},
 978                               },
 979                      );
 980     my $submitted_etag =
 981         $param{cgi}->http('if-none-match');
 982     my $etag =
 983         calculate_etags(files=>$param{files},
 984                         additional_data=>$param{additional_data});
 985     if (not defined $submitted_etag or
 986         length($submitted_etag) != 32
 987         or $etag ne $submitted_etag
 988        ) {
 989         return $etag;
 990     }
 991     if ($etag eq $submitted_etag) {
 992         return 0;
 993     }
 994 }
 995
 996
 997 1;
 998
 999
1000 __END__
1001
1002
1003
1004
1005
1006