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