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