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