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