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.
6 # [Other people have contributed to this file; their copyrights should
8 # Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
14 Debbugs::CGI -- General routines for the cgi scripts
18 use Debbugs::CGI qw(:url :html);
20 html_escape(bug_url($ref,mbox=>'yes',mboxstatus=>'yes'));
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.
36 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
37 use base qw(Exporter);
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);
46 use Storable qw(dclone);
48 use List::Util qw(max);
52 use Debbugs::Text qw(fill_in_template);
58 ($VERSION) = q$Revision: 1.3 $ =~ /^Revision:\s+([^\s+])/;
59 $DEBUG = 0 unless defined $DEBUG;
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),
67 html => [qw(html_escape htmlize_bugs htmlize_packagelinks),
68 qw(maybelink htmlize_addresslinks htmlize_maintlinks),
70 util => [qw(cgi_parameters quitcgi),
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)],
78 Exporter::export_ok_tags(keys %EXPORT_TAGS);
79 $EXPORT_TAGS{all} = [@EXPORT_OK];
89 Sets the url params which will be used to generate urls.
98 my $url = Debbugs::URI->new($_[0]||'');
99 %URL_PARAMS = %{$url->query_form_hash};
106 bug_url($ref,mbox=>'yes',mboxstat=>'yes');
108 Constructs urls which point to a specific
110 XXX use Params::Validate
119 %params = (%URL_PARAMS,@_);
124 carp "bug_url is deprecated, use bug_links instead";
126 return munge_url('bugreport.cgi?',%params,bug=>$ref);
133 %params = (%URL_PARAMS,@_);
138 carp "pkg_url is deprecated, use package_links instead";
139 return munge_url('pkgreport.cgi?',%params);
144 my $url = munge_url($url,%params_to_munge);
146 Munges a url, replacing parameters with %params_to_munge as appropriate.
153 my $new_url = Debbugs::URI->new($url);
154 my @old_param = $new_url->query_form();
156 while (my ($key,$value) = splice @old_param,0,2) {
157 push @new_param,($key,$value) unless exists $params{$key};
159 $new_url->query_form(@new_param,%params);
160 return $new_url->as_string;
166 version_url(package => $package,found => $found,fixed => $fixed)
168 Creates a link to the version cgi script
172 =item package -- source package whose graph to display
174 =item found -- arrayref of found versions
176 =item fixed -- arrayref of fixed versions
178 =item width -- optional width of graph
180 =item height -- optional height of graph
182 =item info -- display html info surrounding graph; defaults to 1 if
183 width and height are not passed.
185 =item collapse -- whether to collapse the graph; defaults to 1 if
186 width and height are passed.
193 my %params = validate_with(params => \@_,
194 spec => {package => {type => SCALAR,
196 found => {type => ARRAYREF,
199 fixed => {type => ARRAYREF,
202 width => {type => SCALAR,
205 height => {type => SCALAR,
208 absolute => {type => BOOLEAN,
211 collapse => {type => BOOLEAN,
214 info => {type => BOOLEAN,
219 if (not defined $params{width} and not defined $params{height}) {
220 $params{info} = 1 if not exists $params{info};
222 my $url = Debbugs::URI->new('version.cgi?');
223 $url->query_form(%params);
224 return $url->as_string;
231 Escapes html entities by calling HTML::Entities::encode_entities;
238 return HTML::Entities::encode_entities($string,q(<>&"'));
241 =head2 cgi_parameters
245 Returns all of the cgi_parameters from a CGI script using CGI::Simple
250 my %options = validate_with(params => \@_,
251 spec => {query => {type => OBJECT,
254 single => {type => ARRAYREF,
257 default => {type => HASHREF,
262 my $q = $options{query};
264 @single{@{$options{single}}} = (1) x @{$options{single}};
266 for my $paramname ($q->param) {
267 if ($single{$paramname}) {
268 $param{$paramname} = $q->param($paramname);
271 $param{$paramname} = [$q->param($paramname)];
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};
287 print "Content-Type: text/html\n\n";
288 print fill_in_template(template=>'cgi/quit',
289 variables => {msg => $msg}
297 =head2 htmlize_packagelinks
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.
307 sub htmlize_packagelinks {
309 return '' unless defined $pkgs and $pkgs ne '';
310 my @pkglist = splitpackages($pkgs);
312 carp "htmlize_packagelinks is deprecated, use package_links instead";
314 return 'Package' . (@pkglist > 1 ? 's' : '') . ': ' .
315 package_links(package =>\@pkglist,
322 join(', ', package_links(packages => \@packages))
324 Given a list of packages, return a list of html which links to the package
328 =item package -- arrayref or scalar of package(s)
330 =item submitter -- arrayref or scalar of submitter(s)
332 =item src -- arrayref or scalar of source(s)
334 =item maintainer -- arrayref or scalar of maintainer(s)
336 =item links_only -- return only links, not htmlized links, defaults to
337 returning htmlized links.
339 =item class -- class of the a href, defaults to ''
345 our @package_search_key_order = (package => 'in package',
347 severity => 'with severity',
348 src => 'in source package',
349 maint => 'in packages maintained by',
350 submitter => 'submitted by',
352 status => 'with status',
353 correspondent => 'with mail from',
354 newest => 'newest bugs',
356 our %package_search_keys = @package_search_key_order;
360 my %param = validate_with(params => \@_,
361 spec => {(map { ($_,{type => SCALAR|ARRAYREF,
364 } keys %package_search_keys,
366 links_only => {type => BOOLEAN,
369 class => {type => SCALAR,
372 separator => {type => SCALAR,
375 options => {type => HASHREF,
382 my %map = (source => 'src',
383 maintainer => 'maint',
386 return $map{$key} if exists $map{$key};
390 my %options = %{$param{options}};
391 for ((keys %package_search_keys,qw(msg att))) {
392 delete $options{$_} if exists $options{$_};
395 for my $type (qw(src package)) {
396 push @links, map {(munge_url('pkgreport.cgi?',
401 } make_list($param{$type}) if exists $param{$type};
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?',
411 } make_list($param{$type}) if exists $param{$type};
414 my ($link,$link_name);
416 if (length $param{class}) {
417 $class = q( class=").html_escape($param{class}).q(");
419 while (($link,$link_name) = splice(@links,0,2)) {
420 if ($param{links_only}) {
426 html_escape($link).q(">).
427 html_escape($link_name).q(</a>);
434 return join($param{separator},@return);
440 join(', ', bug_links(bug => \@packages))
442 Given a list of bugs, return a list of html which links to the bugs
446 =item bug -- arrayref or scalar of bug(s)
448 =item links_only -- return only links, not htmlized links, defaults to
449 returning htmlized links.
451 =item class -- class of the a href, defaults to ''
458 my %param = validate_with(params => \@_,
459 spec => {bug => {type => SCALAR|ARRAYREF,
462 links_only => {type => BOOLEAN,
465 class => {type => SCALAR,
468 separator => {type => SCALAR,
471 options => {type => HASHREF,
476 my %options = %{$param{options}};
479 delete $options{$_} if exists $options{$_};
482 push @links, map {(munge_url('bugreport.cgi?',
487 } make_list($param{bug}) if exists $param{bug};
489 my ($link,$link_name);
491 if (length $param{class}) {
492 $class = q( class=").html_escape($param{class}).q(");
494 while (($link,$link_name) = splice(@links,0,2)) {
495 if ($param{links_only}) {
501 html_escape($link).q(">).
502 html_escape($link_name).q(</a>);
509 return join($param{separator},@return);
518 maybelink('http://foobarbaz,http://bleh',qr/[, ]+/);
519 maybelink('http://foobarbaz,http://bleh',qr/[, ]+/,', ');
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.
530 my ($links,$regex,$join) = @_;
531 $join = ' ' if not defined $join;
534 if (defined $regex) {
535 @segments = split $regex, $links;
538 @segments = ($links);
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>';
544 push @return, html_escape($in);
547 return @return?join($join,@return):'';
551 =head2 htmlize_addresslinks
553 htmlize_addresslinks($prefixfunc,$urlfunc,$addresses,$class);
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.
564 sub htmlize_addresslinks {
565 my ($prefixfunc, $urlfunc, $addresses,$class) = @_;
566 carp "htmlize_addresslinks is deprecated";
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;
575 { sprintf qq(<a ${class}).
577 $urlfunc->($_->address),
578 html_escape($_->format) ||
584 my $prefix = (ref $prefixfunc) ?
585 $prefixfunc->(1) : $prefixfunc;
586 return sprintf '%s<a '.$class.'href="%s">(unknown)</a>',
587 $prefix, $urlfunc->('');
592 my $addr = getparsedaddrs($_[0] || "");
593 $addr = defined $addr?$addr->address:'';
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);
607 our $_maintainer_rev;
611 bug_linklist($separator,$class,@bugs)
613 Creates a set of links to C<@bugs> separated by C<$separator> with
614 link class C<$class>.
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
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);
636 =head2 form_options_and_normal_param
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};
643 Translates from special form_options to a set of parameters which can
644 be used to run the current page.
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.
649 Currently there are two commands which are understood:
650 combine, and concatenate.
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
658 For example, you would have
660 <input type="hidden" name="_fo_combine_key_fo_searchkey_value_fo_searchvalue" value="1">
662 which would combine the _fo_searchkey and _fo_searchvalue input fields, so
664 <input type="text" name="_fo_searchkey" value="foo">
665 <input type="text" name="_fo_searchvalue" value="bar">
667 would yield foo=>'bar' in %param.
671 Concatenate concatenates values into a single entry in a parameter
673 For example, you would have
675 <input type="hidden" name="_fo_concatentate_into_foo_with_:_fo_blah_fo_bleargh" value="1">
677 which would combine the _fo_searchkey and _fo_searchvalue input fields, so
679 <input type="text" name="_fo_blah" value="bar">
680 <input type="text" name="_fo_bleargh" value="baz">
682 would yield foo=>'bar:baz' in %param.
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};
697 $param->{$key} = $orig_param->{$key};
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
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,
721 elsif (my ($field,$concatenate_key,$fields) =
722 $key =~ /concatenate_into_(.+?)((?:_with_[^_])?)
723 ((?:\Q$form_option_leader\E.+?)+)
726 if (length $concatenate_key) {
727 $concatenate_key =~ s/_with_//;
730 $concatenate_key = ':';
732 my @fields = $fields =~ m/(\Q$form_option_leader\E.+?)(?:(?=\Q$form_option_leader\E)|$)/g;
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}});
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,
745 join($concatenate_key,
746 map {$field_list{$_}[$i]} @fields
752 return wantarray?($form_option,$param):$form_option;
757 print option_form(template=>'pkgreport_options',
759 form_options => $form_options,
767 my %param = validate_with(params => \@_,
768 spec => {template => {type => SCALAR,
770 variables => {type => HASHREF,
773 language => {type => SCALAR,
776 param => {type => HASHREF,
779 form_options => {type => HASHREF,
785 # First, we need to see if we need to add particular types of
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
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},
801 elsif ($key =~ /^delete_(.+?)(?:_(\d+))?$/) {
802 next unless exists $variables->{param}{$1};
803 if (ref $variables->{param}{$1} eq 'ARRAY' and
805 defined $variables->{param}{$1}[$2]
807 splice @{$variables->{param}{$1}},$2,1;
810 delete $variables->{param}{$1};
813 # we'll add extra comands here once I figure out what they
816 # add in a few utility routines
817 $variables->{output_select_options} = sub {
818 my ($options,$value) = @_;
819 my @options = @{$options};
821 while (my ($o_value,$name) = splice @options,0,2) {
823 if (defined $value and $o_value eq $value) {
824 $selected = ' selected';
826 $output .= qq(<option value="$o_value"$selected>$name</option>\n);
830 $variables->{make_list} = sub { make_list(@_);
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,
840 my ($param,$key,@values) = @_;
842 if (exists $param->{$key} and not
843 ref $param->{$key}) {
844 @{$param->{$key}} = [$param->{$key},
849 push @{$param->{$key}}, @values;
863 Decodes the funky maintainer encoding.
865 Don't ask me what in the world it does.
871 return () unless @input;
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;
883 wantarray ? @output : $output[0];