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