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              if ($has_options) {
 413                  push @links,
 414                      (munge_url('pkgreport.cgi?',
 415                                 %options,
 416                                 $type => $target),
 417                       $target);
 418              } else {
 419                  push @links,
 420                      ('pkgreport.cgi?'.
 421                       $type.'='.uri_escape_utf8($target),
 422                       $target);
 423              }
 424          }
 425      }
 426      my @return = ();
 427      my ($link,$link_name);
 428      my $class = '';
 429      if (length $param{class}) {
 430           $class = q( class=").html_escape($param{class}).q(");
 431      }
 432      while (($link,$link_name) = splice(@links,0,2)) {
 433           if ($param{links_only}) {
 434                push @return,$link
 435           }
 436           else {
 437                push @return,
 438                     qq(<a$class href=").
 439                          html_escape($link).q(">).
 440                               html_escape($link_name).q(</a>);
 441           }
 442      }
 443      if (wantarray) {
 444           return @return;
 445      }
 446      else {
 447           return join($param{separator},@return);
 448      }
 449 }
 450
 451 =head2 bug_links
 452
 453      join(', ', bug_links(bug => \@packages))
 454
 455 Given a list of bugs, return a list of html which links to the bugs
 456
 457 =over
 458
 459 =item bug -- arrayref or scalar of bug(s)
 460
 461 =item links_only -- return only links, not htmlized links, defaults to
 462 returning htmlized links.
 463
 464 =item class -- class of the a href, defaults to ''
 465
 466 =back
 467
 468 =cut
 469
 470 sub bug_links {
 471      my %param = validate_with(params => \@_,
 472                                spec   => {bug => {type => SCALAR|ARRAYREF,
 473                                                   optional => 1,
 474                                                  },
 475                                           links_only => {type => BOOLEAN,
 476                                                          default => 0,
 477                                                         },
 478                                           class => {type => SCALAR,
 479                                                     default => '',
 480                                                    },
 481                                           separator => {type => SCALAR,
 482                                                         default => ', ',
 483                                                        },
 484                                           options => {type => HASHREF,
 485                                                       default => {},
 486                                                      },
 487                                          },
 488                               );
 489      my %options = %{$param{options}};
 490
 491      for (qw(bug)) {
 492           delete $options{$_} if exists $options{$_};
 493      }
 494      my $has_options = keys %options;
 495      my @links;
 496      if ($has_options) {
 497          push @links, map {(munge_url('bugreport.cgi?',
 498                                       %options,
 499                                       bug => $_,
 500                                      ),
 501                             $_);
 502                        } make_list($param{bug}) if exists $param{bug};
 503      } else {
 504          push @links, map {('bugreport.cgi?bug='.uri_escape_utf8($_),
 505                             $_)}
 506              make_list($param{bug}) if exists $param{bug};
 507      }
 508      my @return;
 509      my ($link,$link_name);
 510      my $class = '';
 511      if (length $param{class}) {
 512           $class = q( class=").html_escape($param{class}).q(");
 513      }
 514      while (($link,$link_name) = splice(@links,0,2)) {
 515           if ($param{links_only}) {
 516                push @return,$link
 517           }
 518           else {
 519                push @return,
 520                     qq(<a$class href=").
 521                          html_escape($link).q(">).
 522                               html_escape($link_name).q(</a>);
 523           }
 524      }
 525      if (wantarray) {
 526           return @return;
 527      }
 528      else {
 529           return join($param{separator},@return);
 530      }
 531 }
 532
 533
 534
 535 =head2 maybelink
 536
 537      maybelink($in);
 538      maybelink('http://foobarbaz,http://bleh',qr/[, ]+/);
 539      maybelink('http://foobarbaz,http://bleh',qr/[, ]+/,', ');
 540
 541
 542 In the first form, links the link if it looks like a link. In the
 543 second form, first splits based on the regex, then reassembles the
 544 link, linking things that look like links. In the third form, rejoins
 545 the split links with commas and spaces.
 546
 547 =cut
 548
 549 sub maybelink {
 550     my ($links,$regex,$join) = @_;
 551     if (not defined $regex and not defined $join) {
 552          $links =~ s{(.*?)((?:(?:ftp|http|https)://[\S~-]+?/?)?)([\)\'\:\.\,]?(?:\s|\.<|$))}
 553                     {html_escape($1).(length $2?q(<a href=").html_escape($2).q(">).html_escape($2).q(</a>):'').html_escape($3)}geimo;
 554          return $links;
 555     }
 556     $join = ' ' if not defined $join;
 557     my @return;
 558     my @segments;
 559     if (defined $regex) {
 560          @segments = split $regex, $links;
 561     }
 562     else {
 563          @segments = ($links);
 564     }
 565     for my $in (@segments) {
 566          if ($in =~ /^[a-zA-Z0-9+.-]+:/) { # RFC 1738 scheme
 567               push @return, qq{<a href="$in">} . html_escape($in) . '</a>';
 568          } else {
 569               push @return, html_escape($in);
 570          }
 571     }
 572     return @return?join($join,@return):'';
 573 }
 574
 575
 576 =head2 htmlize_addresslinks
 577
 578      htmlize_addresslinks($prefixfunc,$urlfunc,$addresses,$class);
 579
 580
 581 Generate a comma-separated list of HTML links to each address given in
 582 $addresses, which should be a comma-separated list of RFC822
 583 addresses. $urlfunc should be a reference to a function like mainturl
 584 or submitterurl which returns the URL for each individual address.
 585
 586
 587 =cut
 588
 589 sub htmlize_addresslinks {
 590      my ($prefixfunc, $urlfunc, $addresses,$class) = @_;
 591      carp "htmlize_addresslinks is deprecated";
 592
 593      $class = defined $class?qq(class="$class" ):'';
 594      if (defined $addresses and $addresses ne '') {
 595           my @addrs = getparsedaddrs($addresses);
 596           my $prefix = (ref $prefixfunc) ?
 597                $prefixfunc->(scalar @addrs):$prefixfunc;
 598           return $prefix .
 599                join(', ', map
 600                     { sprintf qq(<a ${class}).
 601                            'href="%s">%s</a>',
 602                                 $urlfunc->($_->address),
 603                                      html_escape($_->format) ||
 604                                           '(unknown)'
 605                                      } @addrs
 606                    );
 607      }
 608      else {
 609           my $prefix = (ref $prefixfunc) ?
 610                $prefixfunc->(1) : $prefixfunc;
 611           return sprintf '%s<a '.$class.'href="%s">(unknown)</a>',
 612                $prefix, $urlfunc->('');
 613      }
 614 }
 615
 616 sub emailfromrfc822{
 617      my $addr = getparsedaddrs($_[0] || "");
 618      $addr = defined $addr?$addr->address:'';
 619      return $addr;
 620 }
 621
 622 sub mainturl { package_links(maintainer => $_[0], links_only => 1); }
 623 sub submitterurl { package_links(submitter => $_[0], links_only => 1); }
 624 sub htmlize_maintlinks {
 625     my ($prefixfunc, $maints) = @_;
 626     carp "htmlize_maintlinks is deprecated";
 627     return htmlize_addresslinks($prefixfunc, \&mainturl, $maints);
 628 }
 629
 630 =head2 bug_linklist
 631
 632      bug_linklist($separator,$class,@bugs)
 633
 634 Creates a set of links to C<@bugs> separated by C<$separator> with
 635 link class C<$class>.
 636
 637 XXX Use L<Params::Validate>; we want to be able to support query
 638 arguments here too; we should be able to combine bug_links and this
 639 function into one.
 640
 641 =cut
 642
 643
 644 sub bug_linklist{
 645      my ($sep,$class,@bugs) = @_;
 646      carp "bug_linklist is deprecated; use bug_links instead";
 647      return scalar bug_links(bug=>\@bugs,class=>$class,separator=>$sep);
 648 }
 649
 650
 651 sub add_user {
 652      my ($user,$usertags,$bug_usertags,$seen_users,$cats,$hidden) = @_;
 653      $seen_users = {} if not defined $seen_users;
 654      $bug_usertags = {} if not defined $bug_usertags;
 655      $usertags = {} if not defined $usertags;
 656      $cats = {} if not defined $cats;
 657      $hidden = {} if not defined $hidden;
 658      return if exists $seen_users->{$user};
 659      $seen_users->{$user} = 1;
 660
 661      my $u = Debbugs::User::get_user($user);
 662
 663      my %vis = map { $_, 1 } @{$u->{"visible_cats"}};
 664      for my $c (keys %{$u->{"categories"}}) {
 665           $cats->{$c} = $u->{"categories"}->{$c};
 666           $hidden->{$c} = 1 unless defined $vis{$c};
 667      }
 668      for my $t (keys %{$u->{"tags"}}) {
 669           $usertags->{$t} = [] unless defined $usertags->{$t};
 670           push @{$usertags->{$t}}, @{$u->{"tags"}->{$t}};
 671      }
 672
 673      %{$bug_usertags} = ();
 674      for my $t (keys %{$usertags}) {
 675           for my $b (@{$usertags->{$t}}) {
 676                $bug_usertags->{$b} = [] unless defined $bug_usertags->{$b};
 677                push @{$bug_usertags->{$b}}, $t;
 678           }
 679      }
 680 }
 681
 682
 683
 684 =head1 Forms
 685
 686 =cut
 687
 688 =head2 form_options_and_normal_param
 689
 690      my ($form_option,$param) = form_options_and_normal_param(\%param)
 691            if $param{form_options};
 692      my $form_option = form_options_and_normal_param(\%param)
 693            if $param{form_options};
 694
 695 Translates from special form_options to a set of parameters which can
 696 be used to run the current page.
 697
 698 The idea behind this is to allow complex forms to relatively easily
 699 cause options that the existing cgi scripts understand to be set.
 700
 701 Currently there are two commands which are understood:
 702 combine, and concatenate.
 703
 704 =head3 combine
 705
 706 Combine works by entering key,value pairs into the parameters using
 707 the key field option input field, and the value field option input
 708 field.
 709
 710 For example, you would have
 711
 712  <input type="hidden" name="_fo_combine_key_fo_searchkey_value_fo_searchvalue" value="1">
 713
 714 which would combine the _fo_searchkey and _fo_searchvalue input fields, so
 715
 716  <input type="text" name="_fo_searchkey" value="foo">
 717  <input type="text" name="_fo_searchvalue" value="bar">
 718
 719 would yield foo=>'bar' in %param.
 720
 721 =head3 concatenate
 722
 723 Concatenate concatenates values into a single entry in a parameter
 724
 725 For example, you would have
 726
 727  <input type="hidden" name="_fo_concatentate_into_foo_with_:_fo_blah_fo_bleargh" value="1">
 728
 729 which would combine the _fo_searchkey and _fo_searchvalue input fields, so
 730
 731  <input type="text" name="_fo_blah" value="bar">
 732  <input type="text" name="_fo_bleargh" value="baz">
 733
 734 would yield foo=>'bar:baz' in %param.
 735
 736
 737 =cut
 738
 739 my $form_option_leader = '_fo_';
 740 sub form_options_and_normal_param{
 741      my ($orig_param) = @_;
 742      # all form_option parameters start with _fo_
 743      my ($param,$form_option) = ({},{});
 744      for my $key (keys %{$orig_param}) {
 745           if ($key =~ /^\Q$form_option_leader\E/) {
 746                $form_option->{$key} = $orig_param->{$key};
 747           }
 748           else {
 749                $param->{$key} = $orig_param->{$key};
 750           }
 751      }
 752      # at this point, we check for commands
 753  COMMAND: for my $key (keys %{$form_option}) {
 754           $key =~ s/^\Q$form_option_leader\E//;
 755           if (my ($key_name,$value_name) =
 756               $key =~ /combine_key(\Q$form_option_leader\E.+)
 757               _value(\Q$form_option_leader\E.+)$/x
 758              ) {
 759                next unless defined $form_option->{$key_name};
 760                next unless defined $form_option->{$value_name};
 761                my @keys = make_list($form_option->{$key_name});
 762                my @values = make_list($form_option->{$value_name});
 763                for my $i (0 .. $#keys) {
 764                     last if $i > $#values;
 765                     next if not defined $keys[$i];
 766                     next if not defined $values[$i];
 767                     __add_to_param($param,
 768                                    $keys[$i],
 769                                    $values[$i],
 770                                   );
 771                }
 772           }
 773           elsif (my ($field,$concatenate_key,$fields) =
 774                  $key =~ /concatenate_into_(.+?)((?:_with_[^_])?)
 775                           ((?:\Q$form_option_leader\E.+?)+)
 776                           $/x
 777                 ) {
 778                if (length $concatenate_key) {
 779                     $concatenate_key =~ s/_with_//;
 780                }
 781                else {
 782                     $concatenate_key = ':';
 783                }
 784                my @fields = $fields =~ m/(\Q$form_option_leader\E.+?)(?:(?=\Q$form_option_leader\E)|$)/g;
 785                my %field_list;
 786                my $max_num = 0;
 787                for my $f (@fields) {
 788                     next COMMAND unless defined $form_option->{$f};
 789                     $field_list{$f} = [make_list($form_option->{$f})];
 790                     $max_num = max($max_num,$#{$field_list{$f}});
 791                }
 792                for my $i (0 .. $max_num) {
 793                     next unless @fields == grep {$i <= $#{$field_list{$_}} and
 794                                                       defined $field_list{$_}[$i]} @fields;
 795                     __add_to_param($param,
 796                                    $field,
 797                                    join($concatenate_key,
 798                                         map {$field_list{$_}[$i]} @fields
 799                                        )
 800                                   );
 801                }
 802           }
 803      }
 804      return wantarray?($form_option,$param):$form_option;
 805 }
 806
 807 =head2 option_form
 808
 809      print option_form(template=>'pkgreport_options',
 810                        param   => \%param,
 811                        form_options => $form_options,
 812                       )
 813
 814
 815
 816 =cut
 817
 818 sub option_form{
 819      my %param = validate_with(params => \@_,
 820                                spec   => {template => {type => SCALAR,
 821                                                       },
 822                                           variables => {type => HASHREF,
 823                                                         default => {},
 824                                                        },
 825                                           language => {type => SCALAR,
 826                                                        optional => 1,
 827                                                       },
 828                                           param => {type => HASHREF,
 829                                                     default => {},
 830                                                    },
 831                                           form_options => {type => HASHREF,
 832                                                            default => {},
 833                                                           },
 834                                          },
 835                               );
 836
 837      # First, we need to see if we need to add particular types of
 838      # parameters
 839      my $variables = dclone($param{variables});
 840      $variables->{param} = dclone($param{param});
 841      for my $key (keys %{$param{form_option}}) {
 842           # strip out leader; shouldn't be anything here without one,
 843           # but skip stupid things anyway
 844           next unless $key =~ s/^\Q$form_option_leader\E//;
 845           if ($key =~ /^add_(.+)$/) {
 846                # this causes a specific parameter to be added
 847                __add_to_param($variables->{param},
 848                               $1,
 849                               ''
 850                              );
 851           }
 852           elsif ($key =~ /^delete_(.+?)(?:_(\d+))?$/) {
 853                next unless exists $variables->{param}{$1};
 854                if (ref $variables->{param}{$1} eq 'ARRAY' and
 855                    defined $2 and
 856                    defined $variables->{param}{$1}[$2]
 857                   ) {
 858                     splice @{$variables->{param}{$1}},$2,1;
 859                }
 860                else {
 861                     delete $variables->{param}{$1};
 862                }
 863           }
 864           # we'll add extra comands here once I figure out what they
 865           # should be
 866      }
 867      # now at this point, we're ready to create the template
 868      return Debbugs::Text::fill_in_template(template=>$param{template},
 869                                             (exists $param{language}?(language=>$param{language}):()),
 870                                             variables => $variables,
 871                                             hole_var  => {'&html_escape' => \&html_escape,
 872                                                          },
 873                                            );
 874 }
 875
 876 sub __add_to_param{
 877      my ($param,$key,@values) = @_;
 878
 879      if (exists $param->{$key} and not
 880          ref $param->{$key}) {
 881           @{$param->{$key}} = [$param->{$key},
 882                                @values
 883                               ];
 884      }
 885      else {
 886           push @{$param->{$key}}, @values;
 887      }
 888 }
 889
 890
 891
 892 =head1 misc
 893
 894 =cut
 895
 896 =head2 maint_decode
 897
 898      maint_decode
 899
 900 Decodes the funky maintainer encoding.
 901
 902 Don't ask me what in the world it does.
 903
 904 =cut
 905
 906 sub maint_decode {
 907      my @input = @_;
 908      return () unless @input;
 909      my @output;
 910      for my $input (@input) {
 911           my $decoded = $input;
 912           $decoded =~ s/-([^_]+)/-$1_-/g;
 913           $decoded =~ s/_/-20_/g;
 914           $decoded =~ s/^,(.*),(.*),([^,]+)$/$1-40_$2-20_-28_$3-29_/;
 915           $decoded =~ s/^([^,]+),(.*),(.*),/$1-20_-3c_$2-40_$3-3e_/;
 916           $decoded =~ s/\./-2e_/g;
 917           $decoded =~ s/-([0-9a-f]{2})_/pack('H*',$1)/ge;
 918           push @output,$decoded;
 919      }
 920      wantarray ? @output : $output[0];
 921 }
 922
 923 =head1 cache
 924
 925 =head2 calculate_etags
 926
 927     calculate_etags(files => [qw(list of files)],additional_data => [qw(any additional data)]);
 928
 929 =cut
 930
 931 sub calculate_etags {
 932     my %param =
 933         validate_with(params => \@_,
 934                       spec => {files => {type => ARRAYREF,
 935                                          default => [],
 936                                         },
 937                                additional_data => {type => ARRAYREF,
 938                                                    default => [],
 939                                                   },
 940                               },
 941                      );
 942     my @additional_data = @{$param{additional_data}};
 943     for my $file (@{$param{files}}) {
 944         my $st = stat($file) or warn "Unable to stat $file: $!";
 945         push @additional_data,$st->mtime;
 946         push @additional_data,$st->size;
 947     }
 948     return(md5_hex(join('',sort @additional_data)));
 949 }
 950
 951 =head2 etag_does_not_match
 952
 953      etag_does_not_match(cgi=>$q,files=>[qw(list of files)],
 954          additional_data=>[qw(any additional data)])
 955
 956
 957 Checks to see if the CGI request contains an etag which matches the calculated
 958 etag.
 959
 960 If there wasn't an etag given, or the etag given doesn't match, return the etag.
 961
 962 If the etag does match, return 0.
 963
 964 =cut
 965
 966 sub etag_does_not_match {
 967     my %param =
 968         validate_with(params => \@_,
 969                       spec => {files => {type => ARRAYREF,
 970                                          default => [],
 971                                         },
 972                                additional_data => {type => ARRAYREF,
 973                                                    default => [],
 974                                                   },
 975                                cgi => {type => OBJECT},
 976                               },
 977                      );
 978     my $submitted_etag =
 979         $param{cgi}->http('if-none-match');
 980     my $etag =
 981         calculate_etags(files=>$param{files},
 982                         additional_data=>$param{additional_data});
 983     if (not defined $submitted_etag or
 984         length($submitted_etag) != 32
 985         or $etag ne $submitted_etag
 986        ) {
 987         return $etag;
 988     }
 989     if ($etag eq $submitted_etag) {
 990         return 0;
 991     }
 992 }
 993
 994
 995 1;
 996
 997
 998 __END__
 999
1000
1001
1002
1003
1004