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