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