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 {(munge_url('pkgreport.cgi?',
 404                                        %options,
 405                                        $type => $_,
 406                                       ),
 407                              ($type eq 'src'?'src:':'').$_);
 408                        } make_list($param{$type}) if exists $param{$type};
 409      }
 410      for my $type (qw(maint owner submitter correspondent)) {
 411           push @links, map {my $addr = getparsedaddrs($_);
 412                             $addr = defined $addr?$addr->address:'';
 413                             (munge_url('pkgreport.cgi?',
 414                                        %options,
 415                                        $type => $addr,
 416                                       ),
 417                              $_);
 418                        } make_list($param{$type}) if exists $param{$type};
 419      }
 420      my @return = ();
 421      my ($link,$link_name);
 422      my $class = '';
 423      if (length $param{class}) {
 424           $class = q( class=").html_escape($param{class}).q(");
 425      }
 426      while (($link,$link_name) = splice(@links,0,2)) {
 427           if ($param{links_only}) {
 428                push @return,$link
 429           }
 430           else {
 431                push @return,
 432                     qq(<a$class href=").
 433                          html_escape($link).q(">).
 434                               html_escape($link_name).q(</a>);
 435           }
 436      }
 437      if (wantarray) {
 438           return @return;
 439      }
 440      else {
 441           return join($param{separator},@return);
 442      }
 443 }
 444
 445 =head2 bug_links
 446
 447      join(', ', bug_links(bug => \@packages))
 448
 449 Given a list of bugs, return a list of html which links to the bugs
 450
 451 =over
 452
 453 =item bug -- arrayref or scalar of bug(s)
 454
 455 =item links_only -- return only links, not htmlized links, defaults to
 456 returning htmlized links.
 457
 458 =item class -- class of the a href, defaults to ''
 459
 460 =back
 461
 462 =cut
 463
 464 sub bug_links {
 465      my %param = validate_with(params => \@_,
 466                                spec   => {bug => {type => SCALAR|ARRAYREF,
 467                                                   optional => 1,
 468                                                  },
 469                                           links_only => {type => BOOLEAN,
 470                                                          default => 0,
 471                                                         },
 472                                           class => {type => SCALAR,
 473                                                     default => '',
 474                                                    },
 475                                           separator => {type => SCALAR,
 476                                                         default => ', ',
 477                                                        },
 478                                           options => {type => HASHREF,
 479                                                       default => {},
 480                                                      },
 481                                          },
 482                               );
 483      my %options = %{$param{options}};
 484
 485      for (qw(bug)) {
 486           delete $options{$_} if exists $options{$_};
 487      }
 488      my @links;
 489      push @links, map {(munge_url('bugreport.cgi?',
 490                                   %options,
 491                                   bug => $_,
 492                                  ),
 493                         $_);
 494                   } make_list($param{bug}) if exists $param{bug};
 495      my @return;
 496      my ($link,$link_name);
 497      my $class = '';
 498      if (length $param{class}) {
 499           $class = q( class=").html_escape($param{class}).q(");
 500      }
 501      while (($link,$link_name) = splice(@links,0,2)) {
 502           if ($param{links_only}) {
 503                push @return,$link
 504           }
 505           else {
 506                push @return,
 507                     qq(<a$class href=").
 508                          html_escape($link).q(">).
 509                               html_escape($link_name).q(</a>);
 510           }
 511      }
 512      if (wantarray) {
 513           return @return;
 514      }
 515      else {
 516           return join($param{separator},@return);
 517      }
 518 }
 519
 520
 521
 522 =head2 maybelink
 523
 524      maybelink($in);
 525      maybelink('http://foobarbaz,http://bleh',qr/[, ]+/);
 526      maybelink('http://foobarbaz,http://bleh',qr/[, ]+/,', ');
 527
 528
 529 In the first form, links the link if it looks like a link. In the
 530 second form, first splits based on the regex, then reassembles the
 531 link, linking things that look like links. In the third form, rejoins
 532 the split links with commas and spaces.
 533
 534 =cut
 535
 536 sub maybelink {
 537     my ($links,$regex,$join) = @_;
 538     if (not defined $regex and not defined $join) {
 539          $links =~ s{(.*?)((?:(?:ftp|http|https)://[\S~-]+?/?)?)([\)\'\:\.\,]?(?:\s|\.<|$))}
 540                     {html_escape($1).(length $2?q(<a href=").html_escape($2).q(">).html_escape($2).q(</a>):'').html_escape($3)}geimo;
 541          return $links;
 542     }
 543     $join = ' ' if not defined $join;
 544     my @return;
 545     my @segments;
 546     if (defined $regex) {
 547          @segments = split $regex, $links;
 548     }
 549     else {
 550          @segments = ($links);
 551     }
 552     for my $in (@segments) {
 553          if ($in =~ /^[a-zA-Z0-9+.-]+:/) { # RFC 1738 scheme
 554               push @return, qq{<a href="$in">} . html_escape($in) . '</a>';
 555          } else {
 556               push @return, html_escape($in);
 557          }
 558     }
 559     return @return?join($join,@return):'';
 560 }
 561
 562
 563 =head2 htmlize_addresslinks
 564
 565      htmlize_addresslinks($prefixfunc,$urlfunc,$addresses,$class);
 566
 567
 568 Generate a comma-separated list of HTML links to each address given in
 569 $addresses, which should be a comma-separated list of RFC822
 570 addresses. $urlfunc should be a reference to a function like mainturl
 571 or submitterurl which returns the URL for each individual address.
 572
 573
 574 =cut
 575
 576 sub htmlize_addresslinks {
 577      my ($prefixfunc, $urlfunc, $addresses,$class) = @_;
 578      carp "htmlize_addresslinks is deprecated";
 579
 580      $class = defined $class?qq(class="$class" ):'';
 581      if (defined $addresses and $addresses ne '') {
 582           my @addrs = getparsedaddrs($addresses);
 583           my $prefix = (ref $prefixfunc) ?
 584                $prefixfunc->(scalar @addrs):$prefixfunc;
 585           return $prefix .
 586                join(', ', map
 587                     { sprintf qq(<a ${class}).
 588                            'href="%s">%s</a>',
 589                                 $urlfunc->($_->address),
 590                                      html_escape($_->format) ||
 591                                           '(unknown)'
 592                                      } @addrs
 593                    );
 594      }
 595      else {
 596           my $prefix = (ref $prefixfunc) ?
 597                $prefixfunc->(1) : $prefixfunc;
 598           return sprintf '%s<a '.$class.'href="%s">(unknown)</a>',
 599                $prefix, $urlfunc->('');
 600      }
 601 }
 602
 603 sub emailfromrfc822{
 604      my $addr = getparsedaddrs($_[0] || "");
 605      $addr = defined $addr?$addr->address:'';
 606      return $addr;
 607 }
 608
 609 sub mainturl { package_links(maint => $_[0], links_only => 1); }
 610 sub submitterurl { package_links(submitter => $_[0], links_only => 1); }
 611 sub htmlize_maintlinks {
 612     my ($prefixfunc, $maints) = @_;
 613     carp "htmlize_maintlinks is deprecated";
 614     return htmlize_addresslinks($prefixfunc, \&mainturl, $maints);
 615 }
 616
 617
 618 our $_maintainer;
 619 our $_maintainer_rev;
 620
 621 =head2 bug_linklist
 622
 623      bug_linklist($separator,$class,@bugs)
 624
 625 Creates a set of links to C<@bugs> separated by C<$separator> with
 626 link class C<$class>.
 627
 628 XXX Use L<Params::Validate>; we want to be able to support query
 629 arguments here too; we should be able to combine bug_links and this
 630 function into one. [Hell, bug_url should be one function with this one
 631 too.]
 632
 633 =cut
 634
 635
 636 sub bug_linklist{
 637      my ($sep,$class,@bugs) = @_;
 638      carp "bug_linklist is deprecated; use bug_links instead";
 639      return scalar bug_links(bug=>\@bugs,class=>$class,separator=>$sep);
 640 }
 641
 642
 643 sub add_user {
 644      my ($user,$usertags,$bug_usertags,$seen_users,$cats,$hidden) = @_;
 645      $seen_users = {} if not defined $seen_users;
 646      $bug_usertags = {} if not defined $bug_usertags;
 647      $usertags = {} if not defined $usertags;
 648      $cats = {} if not defined $cats;
 649      $hidden = {} if not defined $hidden;
 650      return if exists $seen_users->{$user};
 651      $seen_users->{$user} = 1;
 652
 653      my $u = Debbugs::User::get_user($user);
 654
 655      my %vis = map { $_, 1 } @{$u->{"visible_cats"}};
 656      for my $c (keys %{$u->{"categories"}}) {
 657           $cats->{$c} = $u->{"categories"}->{$c};
 658           $hidden->{$c} = 1 unless defined $vis{$c};
 659      }
 660      for my $t (keys %{$u->{"tags"}}) {
 661           $usertags->{$t} = [] unless defined $usertags->{$t};
 662           push @{$usertags->{$t}}, @{$u->{"tags"}->{$t}};
 663      }
 664
 665      %{$bug_usertags} = ();
 666      for my $t (keys %{$usertags}) {
 667           for my $b (@{$usertags->{$t}}) {
 668                $bug_usertags->{$b} = [] unless defined $bug_usertags->{$b};
 669                push @{$bug_usertags->{$b}}, $t;
 670           }
 671      }
 672 }
 673
 674
 675
 676 =head1 Forms
 677
 678 =cut
 679
 680 =head2 form_options_and_normal_param
 681
 682      my ($form_option,$param) = form_options_and_normal_param(\%param)
 683            if $param{form_options};
 684      my $form_option = form_options_and_normal_param(\%param)
 685            if $param{form_options};
 686
 687 Translates from special form_options to a set of parameters which can
 688 be used to run the current page.
 689
 690 The idea behind this is to allow complex forms to relatively easily
 691 cause options that the existing cgi scripts understand to be set.
 692
 693 Currently there are two commands which are understood:
 694 combine, and concatenate.
 695
 696 =head3 combine
 697
 698 Combine works by entering key,value pairs into the parameters using
 699 the key field option input field, and the value field option input
 700 field.
 701
 702 For example, you would have
 703
 704  <input type="hidden" name="_fo_combine_key_fo_searchkey_value_fo_searchvalue" value="1">
 705
 706 which would combine the _fo_searchkey and _fo_searchvalue input fields, so
 707
 708  <input type="text" name="_fo_searchkey" value="foo">
 709  <input type="text" name="_fo_searchvalue" value="bar">
 710
 711 would yield foo=>'bar' in %param.
 712
 713 =head3 concatenate
 714
 715 Concatenate concatenates values into a single entry in a parameter
 716
 717 For example, you would have
 718
 719  <input type="hidden" name="_fo_concatentate_into_foo_with_:_fo_blah_fo_bleargh" value="1">
 720
 721 which would combine the _fo_searchkey and _fo_searchvalue input fields, so
 722
 723  <input type="text" name="_fo_blah" value="bar">
 724  <input type="text" name="_fo_bleargh" value="baz">
 725
 726 would yield foo=>'bar:baz' in %param.
 727
 728
 729 =cut
 730
 731 my $form_option_leader = '_fo_';
 732 sub form_options_and_normal_param{
 733      my ($orig_param) = @_;
 734      # all form_option parameters start with _fo_
 735      my ($param,$form_option) = ({},{});
 736      for my $key (keys %{$orig_param}) {
 737           if ($key =~ /^\Q$form_option_leader\E/) {
 738                $form_option->{$key} = $orig_param->{$key};
 739           }
 740           else {
 741                $param->{$key} = $orig_param->{$key};
 742           }
 743      }
 744      # at this point, we check for commands
 745  COMMAND: for my $key (keys %{$form_option}) {
 746           $key =~ s/^\Q$form_option_leader\E//;
 747           if (my ($key_name,$value_name) =
 748               $key =~ /combine_key(\Q$form_option_leader\E.+)
 749               _value(\Q$form_option_leader\E.+)$/x
 750              ) {
 751                next unless defined $form_option->{$key_name};
 752                next unless defined $form_option->{$value_name};
 753                my @keys = make_list($form_option->{$key_name});
 754                my @values = make_list($form_option->{$value_name});
 755                for my $i (0 .. $#keys) {
 756                     last if $i > $#values;
 757                     next if not defined $keys[$i];
 758                     next if not defined $values[$i];
 759                     __add_to_param($param,
 760                                    $keys[$i],
 761                                    $values[$i],
 762                                   );
 763                }
 764           }
 765           elsif (my ($field,$concatenate_key,$fields) =
 766                  $key =~ /concatenate_into_(.+?)((?:_with_[^_])?)
 767                           ((?:\Q$form_option_leader\E.+?)+)
 768                           $/x
 769                 ) {
 770                if (length $concatenate_key) {
 771                     $concatenate_key =~ s/_with_//;
 772                }
 773                else {
 774                     $concatenate_key = ':';
 775                }
 776                my @fields = $fields =~ m/(\Q$form_option_leader\E.+?)(?:(?=\Q$form_option_leader\E)|$)/g;
 777                my %field_list;
 778                my $max_num = 0;
 779                for my $f (@fields) {
 780                     next COMMAND unless defined $form_option->{$f};
 781                     $field_list{$f} = [make_list($form_option->{$f})];
 782                     $max_num = max($max_num,$#{$field_list{$f}});
 783                }
 784                for my $i (0 .. $max_num) {
 785                     next unless @fields == grep {$i <= $#{$field_list{$_}} and
 786                                                       defined $field_list{$_}[$i]} @fields;
 787                     __add_to_param($param,
 788                                    $field,
 789                                    join($concatenate_key,
 790                                         map {$field_list{$_}[$i]} @fields
 791                                        )
 792                                   );
 793                }
 794           }
 795      }
 796      return wantarray?($form_option,$param):$form_option;
 797 }
 798
 799 =head2 option_form
 800
 801      print option_form(template=>'pkgreport_options',
 802                        param   => \%param,
 803                        form_options => $form_options,
 804                       )
 805
 806
 807
 808 =cut
 809
 810 sub option_form{
 811      my %param = validate_with(params => \@_,
 812                                spec   => {template => {type => SCALAR,
 813                                                       },
 814                                           variables => {type => HASHREF,
 815                                                         default => {},
 816                                                        },
 817                                           language => {type => SCALAR,
 818                                                        optional => 1,
 819                                                       },
 820                                           param => {type => HASHREF,
 821                                                     default => {},
 822                                                    },
 823                                           form_options => {type => HASHREF,
 824                                                            default => {},
 825                                                           },
 826                                          },
 827                               );
 828
 829      # First, we need to see if we need to add particular types of
 830      # parameters
 831      my $variables = dclone($param{variables});
 832      $variables->{param} = dclone($param{param});
 833      for my $key (keys %{$param{form_option}}) {
 834           # strip out leader; shouldn't be anything here without one,
 835           # but skip stupid things anyway
 836           my $o_key = $key;
 837           next unless $key =~ s/^\Q$form_option_leader\E//;
 838           if ($key =~ /^add_(.+)$/) {
 839                # this causes a specific parameter to be added
 840                __add_to_param($variables->{param},
 841                               $1,
 842                               ''
 843                              );
 844           }
 845           elsif ($key =~ /^delete_(.+?)(?:_(\d+))?$/) {
 846                next unless exists $variables->{param}{$1};
 847                if (ref $variables->{param}{$1} eq 'ARRAY' and
 848                    defined $2 and
 849                    defined $variables->{param}{$1}[$2]
 850                   ) {
 851                     splice @{$variables->{param}{$1}},$2,1;
 852                }
 853                else {
 854                     delete $variables->{param}{$1};
 855                }
 856           }
 857           # we'll add extra comands here once I figure out what they
 858           # should be
 859      }
 860      # add in a few utility routines
 861      $variables->{output_select_options} = sub {
 862           my ($options,$value) = @_;
 863           my @options = @{$options};
 864           my $output = '';
 865           while (my ($o_value,$name) = splice @options,0,2) {
 866                my $selected = '';
 867                if (defined $value and $o_value eq $value) {
 868                     $selected = ' selected';
 869                }
 870                $output .= q(<option value=").html_escape($o_value).qq("$selected>).
 871                    html_escape($name).qq(</option>\n);
 872           }
 873           return $output;
 874      };
 875      $variables->{make_list} = sub { make_list(@_);
 876      };
 877      # now at this point, we're ready to create the template
 878      return Debbugs::Text::fill_in_template(template=>$param{template},
 879                                             (exists $param{language}?(language=>$param{language}):()),
 880                                             variables => $variables,
 881                                             hole_var  => {'&html_escape' => \&html_escape,
 882                                                          },
 883                                            );
 884 }
 885
 886 sub __add_to_param{
 887      my ($param,$key,@values) = @_;
 888
 889      if (exists $param->{$key} and not
 890          ref $param->{$key}) {
 891           @{$param->{$key}} = [$param->{$key},
 892                                @values
 893                               ];
 894      }
 895      else {
 896           push @{$param->{$key}}, @values;
 897      }
 898 }
 899
 900
 901
 902 =head1 misc
 903
 904 =cut
 905
 906 =head2 maint_decode
 907
 908      maint_decode
 909
 910 Decodes the funky maintainer encoding.
 911
 912 Don't ask me what in the world it does.
 913
 914 =cut
 915
 916 sub maint_decode {
 917      my @input = @_;
 918      return () unless @input;
 919      my @output;
 920      for my $input (@input) {
 921           my $decoded = $input;
 922           $decoded =~ s/-([^_]+)/-$1_-/g;
 923           $decoded =~ s/_/-20_/g;
 924           $decoded =~ s/^,(.*),(.*),([^,]+)$/$1-40_$2-20_-28_$3-29_/;
 925           $decoded =~ s/^([^,]+),(.*),(.*),/$1-20_-3c_$2-40_$3-3e_/;
 926           $decoded =~ s/\./-2e_/g;
 927           $decoded =~ s/-([0-9a-f]{2})_/pack('H*',$1)/ge;
 928           push @output,$decoded;
 929      }
 930      wantarray ? @output : $output[0];
 931 }
 932
 933
 934 1;
 935
 936
 937 __END__
 938
 939
 940
 941
 942
 943