Debbugs/CGI.pm

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