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