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