Debbugs/CGI.pm

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