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     if (not defined $regex and not defined $join) {
 534          $links =~ s{((?:ftp|http|https)://[\S~-]+?/?)([\)\'\:\.\,]?(?:\s|\.<|$))}
 535                     {q(<a href=\").html_escape($1).q(\">).html_escape($1).q(</a>).$2}geimo;
 536          return $links;
 537     }
 538     $join = ' ' if not defined $join;
 539     my @return;
 540     my @segments;
 541     if (defined $regex) {
 542          @segments = split $regex, $links;
 543     }
 544     else {
 545          @segments = ($links);
 546     }
 547     for my $in (@segments) {
 548          if ($in =~ /^[a-zA-Z0-9+.-]+:/) { # RFC 1738 scheme
 549               push @return, qq{<a href="$in">} . html_escape($in) . '</a>';
 550          } else {
 551               push @return, html_escape($in);
 552          }
 553     }
 554     return @return?join($join,@return):'';
 555 }
 556
 557
 558 =head2 htmlize_addresslinks
 559
 560      htmlize_addresslinks($prefixfunc,$urlfunc,$addresses,$class);
 561
 562
 563 Generate a comma-separated list of HTML links to each address given in
 564 $addresses, which should be a comma-separated list of RFC822
 565 addresses. $urlfunc should be a reference to a function like mainturl
 566 or submitterurl which returns the URL for each individual address.
 567
 568
 569 =cut
 570
 571 sub htmlize_addresslinks {
 572      my ($prefixfunc, $urlfunc, $addresses,$class) = @_;
 573      carp "htmlize_addresslinks is deprecated";
 574
 575      $class = defined $class?qq(class="$class" ):'';
 576      if (defined $addresses and $addresses ne '') {
 577           my @addrs = getparsedaddrs($addresses);
 578           my $prefix = (ref $prefixfunc) ?
 579                $prefixfunc->(scalar @addrs):$prefixfunc;
 580           return $prefix .
 581                join(', ', map
 582                     { sprintf qq(<a ${class}).
 583                            'href="%s">%s</a>',
 584                                 $urlfunc->($_->address),
 585                                      html_escape($_->format) ||
 586                                           '(unknown)'
 587                                      } @addrs
 588                    );
 589      }
 590      else {
 591           my $prefix = (ref $prefixfunc) ?
 592                $prefixfunc->(1) : $prefixfunc;
 593           return sprintf '%s<a '.$class.'href="%s">(unknown)</a>',
 594                $prefix, $urlfunc->('');
 595      }
 596 }
 597
 598 sub emailfromrfc822{
 599      my $addr = getparsedaddrs($_[0] || "");
 600      $addr = defined $addr?$addr->address:'';
 601      return $addr;
 602 }
 603
 604 sub mainturl { package_links(maint => $_[0], links_only => 1); }
 605 sub submitterurl { package_links(submitter => $_[0], links_only => 1); }
 606 sub htmlize_maintlinks {
 607     my ($prefixfunc, $maints) = @_;
 608     carp "htmlize_maintlinks is deprecated";
 609     return htmlize_addresslinks($prefixfunc, \&mainturl, $maints);
 610 }
 611
 612
 613 our $_maintainer;
 614 our $_maintainer_rev;
 615
 616 =head2 bug_linklist
 617
 618      bug_linklist($separator,$class,@bugs)
 619
 620 Creates a set of links to C<@bugs> separated by C<$separator> with
 621 link class C<$class>.
 622
 623 XXX Use L<Params::Validate>; we want to be able to support query
 624 arguments here too; we should be able to combine bug_links and this
 625 function into one. [Hell, bug_url should be one function with this one
 626 too.]
 627
 628 =cut
 629
 630
 631 sub bug_linklist{
 632      my ($sep,$class,@bugs) = @_;
 633      carp "bug_linklist is deprecated; use bug_links instead";
 634      return scalar bug_links(bug=>\@bugs,class=>$class,separator=>$sep);
 635 }
 636
 637
 638
 639 =head1 Forms
 640
 641 =cut
 642
 643 =head2 form_options_and_normal_param
 644
 645      my ($form_option,$param) = form_options_and_normal_param(\%param)
 646            if $param{form_options};
 647      my $form_option = form_options_and_normal_param(\%param)
 648            if $param{form_options};
 649
 650 Translates from special form_options to a set of parameters which can
 651 be used to run the current page.
 652
 653 The idea behind this is to allow complex forms to relatively easily
 654 cause options that the existing cgi scripts understand to be set.
 655
 656 Currently there are two commands which are understood:
 657 combine, and concatenate.
 658
 659 =head3 combine
 660
 661 Combine works by entering key,value pairs into the parameters using
 662 the key field option input field, and the value field option input
 663 field.
 664
 665 For example, you would have
 666
 667  <input type="hidden" name="_fo_combine_key_fo_searchkey_value_fo_searchvalue" value="1">
 668
 669 which would combine the _fo_searchkey and _fo_searchvalue input fields, so
 670
 671  <input type="text" name="_fo_searchkey" value="foo">
 672  <input type="text" name="_fo_searchvalue" value="bar">
 673
 674 would yield foo=>'bar' in %param.
 675
 676 =head3 concatenate
 677
 678 Concatenate concatenates values into a single entry in a parameter
 679
 680 For example, you would have
 681
 682  <input type="hidden" name="_fo_concatentate_into_foo_with_:_fo_blah_fo_bleargh" value="1">
 683
 684 which would combine the _fo_searchkey and _fo_searchvalue input fields, so
 685
 686  <input type="text" name="_fo_blah" value="bar">
 687  <input type="text" name="_fo_bleargh" value="baz">
 688
 689 would yield foo=>'bar:baz' in %param.
 690
 691
 692 =cut
 693
 694 my $form_option_leader = '_fo_';
 695 sub form_options_and_normal_param{
 696      my ($orig_param) = @_;
 697      # all form_option parameters start with _fo_
 698      my ($param,$form_option) = ({},{});
 699      for my $key (keys %{$orig_param}) {
 700           if ($key =~ /^\Q$form_option_leader\E/) {
 701                $form_option->{$key} = $orig_param->{$key};
 702           }
 703           else {
 704                $param->{$key} = $orig_param->{$key};
 705           }
 706      }
 707      # at this point, we check for commands
 708  COMMAND: for my $key (keys %{$form_option}) {
 709           $key =~ s/^\Q$form_option_leader\E//;
 710           if (my ($key_name,$value_name) =
 711               $key =~ /combine_key(\Q$form_option_leader\E.+)
 712               _value(\Q$form_option_leader\E.+)$/x
 713              ) {
 714                next unless defined $form_option->{$key_name};
 715                next unless defined $form_option->{$value_name};
 716                my @keys = make_list($form_option->{$key_name});
 717                my @values = make_list($form_option->{$value_name});
 718                for my $i (0 .. $#keys) {
 719                     last if $i > $#values;
 720                     next if not defined $keys[$i];
 721                     next if not defined $values[$i];
 722                     __add_to_param($param,
 723                                    $keys[$i],
 724                                    $values[$i],
 725                                   );
 726                }
 727           }
 728           elsif (my ($field,$concatenate_key,$fields) =
 729                  $key =~ /concatenate_into_(.+?)((?:_with_[^_])?)
 730                           ((?:\Q$form_option_leader\E.+?)+)
 731                           $/x
 732                 ) {
 733                if (length $concatenate_key) {
 734                     $concatenate_key =~ s/_with_//;
 735                }
 736                else {
 737                     $concatenate_key = ':';
 738                }
 739                my @fields = $fields =~ m/(\Q$form_option_leader\E.+?)(?:(?=\Q$form_option_leader\E)|$)/g;
 740                my %field_list;
 741                my $max_num = 0;
 742                for my $f (@fields) {
 743                     next COMMAND unless defined $form_option->{$f};
 744                     $field_list{$f} = [make_list($form_option->{$f})];
 745                     $max_num = max($max_num,$#{$field_list{$f}});
 746                }
 747                for my $i (0 .. $max_num) {
 748                     next unless @fields == grep {$i <= $#{$field_list{$_}} and
 749                                                       defined $field_list{$_}[$i]} @fields;
 750                     __add_to_param($param,
 751                                    $field,
 752                                    join($concatenate_key,
 753                                         map {$field_list{$_}[$i]} @fields
 754                                        )
 755                                   );
 756                }
 757           }
 758      }
 759      return wantarray?($form_option,$param):$form_option;
 760 }
 761
 762 =head2 option_form
 763
 764      print option_form(template=>'pkgreport_options',
 765                        param   => \%param,
 766                        form_options => $form_options,
 767                       )
 768
 769
 770
 771 =cut
 772
 773 sub option_form{
 774      my %param = validate_with(params => \@_,
 775                                spec   => {template => {type => SCALAR,
 776                                                       },
 777                                           variables => {type => HASHREF,
 778                                                         default => {},
 779                                                        },
 780                                           language => {type => SCALAR,
 781                                                        optional => 1,
 782                                                       },
 783                                           param => {type => HASHREF,
 784                                                     default => {},
 785                                                    },
 786                                           form_options => {type => HASHREF,
 787                                                            default => {},
 788                                                           },
 789                                          },
 790                               );
 791
 792      # First, we need to see if we need to add particular types of
 793      # parameters
 794      my $variables = dclone($param{variables});
 795      $variables->{param} = dclone($param{param});
 796      for my $key (keys %{$param{form_option}}) {
 797           # strip out leader; shouldn't be anything here without one,
 798           # but skip stupid things anyway
 799           my $o_key = $key;
 800           next unless $key =~ s/^\Q$form_option_leader\E//;
 801           if ($key =~ /^add_(.+)$/) {
 802                # this causes a specific parameter to be added
 803                __add_to_param($variables->{param},
 804                               $1,
 805                               ''
 806                              );
 807           }
 808           elsif ($key =~ /^delete_(.+?)(?:_(\d+))?$/) {
 809                next unless exists $variables->{param}{$1};
 810                if (ref $variables->{param}{$1} eq 'ARRAY' and
 811                    defined $2 and
 812                    defined $variables->{param}{$1}[$2]
 813                   ) {
 814                     splice @{$variables->{param}{$1}},$2,1;
 815                }
 816                else {
 817                     delete $variables->{param}{$1};
 818                }
 819           }
 820           # we'll add extra comands here once I figure out what they
 821           # should be
 822      }
 823      # add in a few utility routines
 824      $variables->{output_select_options} = sub {
 825           my ($options,$value) = @_;
 826           my @options = @{$options};
 827           my $output = '';
 828           while (my ($o_value,$name) = splice @options,0,2) {
 829                my $selected = '';
 830                if (defined $value and $o_value eq $value) {
 831                     $selected = ' selected';
 832                }
 833                $output .= qq(<option value="$o_value"$selected>$name</option>\n);
 834           }
 835           return $output;
 836      };
 837      $variables->{make_list} = sub { make_list(@_);
 838      };
 839      # now at this point, we're ready to create the template
 840      return Debbugs::Text::fill_in_template(template=>$param{template},
 841                                             (exists $param{language}?(language=>$param{language}):()),
 842                                             variables => $variables,
 843                                            );
 844 }
 845
 846 sub __add_to_param{
 847      my ($param,$key,@values) = @_;
 848
 849      if (exists $param->{$key} and not
 850          ref $param->{$key}) {
 851           @{$param->{$key}} = [$param->{$key},
 852                                @values
 853                               ];
 854      }
 855      else {
 856           push @{$param->{$key}}, @values;
 857      }
 858 }
 859
 860
 861
 862 =head1 misc
 863
 864 =cut
 865
 866 =head2 maint_decode
 867
 868      maint_decode
 869
 870 Decodes the funky maintainer encoding.
 871
 872 Don't ask me what in the world it does.
 873
 874 =cut
 875
 876 sub maint_decode {
 877      my @input = @_;
 878      return () unless @input;
 879      my @output;
 880      for my $input (@input) {
 881           my $decoded = $input;
 882           $decoded =~ s/-([^_]+)/-$1_-/g;
 883           $decoded =~ s/_/-20_/g;
 884           $decoded =~ s/^,(.*),(.*),([^,]+)$/$1-40_$2-20_-28_$3-29_/;
 885           $decoded =~ s/^([^,]+),(.*),(.*),/$1-20_-3c_$2-40_$3-3e_/;
 886           $decoded =~ s/\./-2e_/g;
 887           $decoded =~ s/-([0-9a-f]{2})_/pack('H*',$1)/ge;
 888           push @output,$decoded;
 889      }
 890      wantarray ? @output : $output[0];
 891 }
 892
 893
 894 1;
 895
 896
 897 __END__
 898
 899
 900
 901
 902
 903