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