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