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