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);
41 use Debbugs::Common qw(getparsedaddrs make_list);
42 use Params::Validate qw(validate_with :types);
44 use Debbugs::Config qw(:config);
45 use Debbugs::Status qw(splitpackages isstrongseverity);
46 use Debbugs::User qw();
50 use Storable qw(dclone);
52 use List::Util qw(max);
56 use Debbugs::Text qw(fill_in_template);
62 ($VERSION) = q$Revision: 1.3 $ =~ /^Revision:\s+([^\s+])/;
63 $DEBUG = 0 unless defined $DEBUG;
66 %EXPORT_TAGS = (url => [qw(bug_url bug_links bug_linklist maybelink),
67 qw(set_url_params pkg_url version_url),
68 qw(submitterurl mainturl munge_url),
69 qw(package_links bug_links),
71 html => [qw(html_escape htmlize_bugs htmlize_packagelinks),
72 qw(maybelink htmlize_addresslinks htmlize_maintlinks),
74 util => [qw(cgi_parameters quitcgi),
76 forms => [qw(option_form form_options_and_normal_param)],
77 usertags => [qw(add_user)],
78 misc => [qw(maint_decode)],
79 package_search => [qw(@package_search_key_order %package_search_keys)],
80 #status => [qw(getbugstatus)],
83 Exporter::export_ok_tags(keys %EXPORT_TAGS);
84 $EXPORT_TAGS{all} = [@EXPORT_OK];
94 Sets the url params which will be used to generate urls.
103 my $url = Debbugs::URI->new($_[0]||'');
104 %URL_PARAMS = %{$url->query_form_hash};
111 bug_url($ref,mbox=>'yes',mboxstat=>'yes');
113 Constructs urls which point to a specific
115 XXX use Params::Validate
124 %params = (%URL_PARAMS,@_);
129 carp "bug_url is deprecated, use bug_links instead";
131 return munge_url('bugreport.cgi?',%params,bug=>$ref);
138 %params = (%URL_PARAMS,@_);
143 carp "pkg_url is deprecated, use package_links instead";
144 return munge_url('pkgreport.cgi?',%params);
149 my $url = munge_url($url,%params_to_munge);
151 Munges a url, replacing parameters with %params_to_munge as appropriate.
158 my $new_url = Debbugs::URI->new($url);
159 my @old_param = $new_url->query_form();
161 while (my ($key,$value) = splice @old_param,0,2) {
162 push @new_param,($key,$value) unless exists $params{$key};
164 $new_url->query_form(@new_param,%params);
165 return $new_url->as_string;
171 version_url(package => $package,found => $found,fixed => $fixed)
173 Creates a link to the version cgi script
177 =item package -- source package whose graph to display
179 =item found -- arrayref of found versions
181 =item fixed -- arrayref of fixed versions
183 =item width -- optional width of graph
185 =item height -- optional height of graph
187 =item info -- display html info surrounding graph; defaults to 1 if
188 width and height are not passed.
190 =item collapse -- whether to collapse the graph; defaults to 1 if
191 width and height are passed.
198 my %params = validate_with(params => \@_,
199 spec => {package => {type => SCALAR|ARRAYREF,
201 found => {type => ARRAYREF,
204 fixed => {type => ARRAYREF,
207 width => {type => SCALAR,
210 height => {type => SCALAR,
213 absolute => {type => BOOLEAN,
216 collapse => {type => BOOLEAN,
219 info => {type => BOOLEAN,
224 if (not defined $params{width} and not defined $params{height}) {
225 $params{info} = 1 if not exists $params{info};
227 my $url = Debbugs::URI->new('version.cgi?');
228 $url->query_form(%params);
229 return $url->as_string;
236 Escapes html entities by calling HTML::Entities::encode_entities;
243 return HTML::Entities::encode_entities($string,q(<>&"'));
246 =head2 cgi_parameters
250 Returns all of the cgi_parameters from a CGI script using CGI::Simple
255 my %options = validate_with(params => \@_,
256 spec => {query => {type => OBJECT,
259 single => {type => ARRAYREF,
262 default => {type => HASHREF,
267 my $q = $options{query};
269 @single{@{$options{single}}} = (1) x @{$options{single}};
271 for my $paramname ($q->param) {
272 if ($single{$paramname}) {
273 $param{$paramname} = $q->param($paramname);
276 $param{$paramname} = [$q->param($paramname)];
279 for my $default (keys %{$options{default}}) {
280 if (not exists $param{$default}) {
281 # We'll clone the reference here to avoid surprises later.
282 $param{$default} = ref($options{default}{$default})?
283 dclone($options{default}{$default}):$options{default}{$default};
292 print "Content-Type: text/html\n\n";
293 print fill_in_template(template=>'cgi/quit',
294 variables => {msg => $msg}
302 =head2 htmlize_packagelinks
306 Given a scalar containing a list of packages separated by something
307 that L<Debbugs::CGI/splitpackages> can separate, returns a
308 formatted set of links to packages in html.
312 sub htmlize_packagelinks {
314 return '' unless defined $pkgs and $pkgs ne '';
315 my @pkglist = splitpackages($pkgs);
317 carp "htmlize_packagelinks is deprecated, use package_links instead";
319 return 'Package' . (@pkglist > 1 ? 's' : '') . ': ' .
320 package_links(package =>\@pkglist,
327 join(', ', package_links(packages => \@packages))
329 Given a list of packages, return a list of html which links to the package
333 =item package -- arrayref or scalar of package(s)
335 =item submitter -- arrayref or scalar of submitter(s)
337 =item src -- arrayref or scalar of source(s)
339 =item maintainer -- arrayref or scalar of maintainer(s)
341 =item links_only -- return only links, not htmlized links, defaults to
342 returning htmlized links.
344 =item class -- class of the a href, defaults to ''
350 our @package_search_key_order = (package => 'in package',
352 severity => 'with severity',
353 src => 'in source package',
354 maint => 'in packages maintained by',
355 submitter => 'submitted by',
357 status => 'with status',
358 affects => 'which affect package',
359 correspondent => 'with mail from',
360 newest => 'newest bugs',
363 our %package_search_keys = @package_search_key_order;
367 my %param = validate_with(params => \@_,
368 spec => {(map { ($_,{type => SCALAR|ARRAYREF,
371 } keys %package_search_keys,
373 links_only => {type => BOOLEAN,
376 class => {type => SCALAR,
379 separator => {type => SCALAR,
382 options => {type => HASHREF,
389 my %map = (source => 'src',
390 maintainer => 'maint',
393 return $map{$key} if exists $map{$key};
397 my %options = %{$param{options}};
398 for ((keys %package_search_keys,qw(msg att))) {
399 delete $options{$_} if exists $options{$_};
402 for my $type (qw(src package)) {
403 push @links, map {my $t_type = $type;
404 if ($_ =~ s/^src://) {
407 (munge_url('pkgreport.cgi?',
411 ($t_type eq 'src'?'src:':'').$_);
412 } make_list($param{$type}) if exists $param{$type};
414 for my $type (qw(maint owner submitter correspondent)) {
415 push @links, map {my $addr = getparsedaddrs($_);
416 $addr = defined $addr?$addr->address:'';
417 (munge_url('pkgreport.cgi?',
422 } make_list($param{$type}) if exists $param{$type};
425 my ($link,$link_name);
427 if (length $param{class}) {
428 $class = q( class=").html_escape($param{class}).q(");
430 while (($link,$link_name) = splice(@links,0,2)) {
431 if ($param{links_only}) {
437 html_escape($link).q(">).
438 html_escape($link_name).q(</a>);
445 return join($param{separator},@return);
451 join(', ', bug_links(bug => \@packages))
453 Given a list of bugs, return a list of html which links to the bugs
457 =item bug -- arrayref or scalar of bug(s)
459 =item links_only -- return only links, not htmlized links, defaults to
460 returning htmlized links.
462 =item class -- class of the a href, defaults to ''
469 my %param = validate_with(params => \@_,
470 spec => {bug => {type => SCALAR|ARRAYREF,
473 links_only => {type => BOOLEAN,
476 class => {type => SCALAR,
479 separator => {type => SCALAR,
482 options => {type => HASHREF,
487 my %options = %{$param{options}};
490 delete $options{$_} if exists $options{$_};
493 push @links, map {(munge_url('bugreport.cgi?',
498 } make_list($param{bug}) if exists $param{bug};
500 my ($link,$link_name);
502 if (length $param{class}) {
503 $class = q( class=").html_escape($param{class}).q(");
505 while (($link,$link_name) = splice(@links,0,2)) {
506 if ($param{links_only}) {
512 html_escape($link).q(">).
513 html_escape($link_name).q(</a>);
520 return join($param{separator},@return);
529 maybelink('http://foobarbaz,http://bleh',qr/[, ]+/);
530 maybelink('http://foobarbaz,http://bleh',qr/[, ]+/,', ');
533 In the first form, links the link if it looks like a link. In the
534 second form, first splits based on the regex, then reassembles the
535 link, linking things that look like links. In the third form, rejoins
536 the split links with commas and spaces.
541 my ($links,$regex,$join) = @_;
542 if (not defined $regex and not defined $join) {
543 $links =~ s{(.*?)((?:(?:ftp|http|https)://[\S~-]+?/?)?)([\)\'\:\.\,]?(?:\s|\.<|$))}
544 {html_escape($1).(length $2?q(<a href=").html_escape($2).q(">).html_escape($2).q(</a>):'').html_escape($3)}geimo;
547 $join = ' ' if not defined $join;
550 if (defined $regex) {
551 @segments = split $regex, $links;
554 @segments = ($links);
556 for my $in (@segments) {
557 if ($in =~ /^[a-zA-Z0-9+.-]+:/) { # RFC 1738 scheme
558 push @return, qq{<a href="$in">} . html_escape($in) . '</a>';
560 push @return, html_escape($in);
563 return @return?join($join,@return):'';
567 =head2 htmlize_addresslinks
569 htmlize_addresslinks($prefixfunc,$urlfunc,$addresses,$class);
572 Generate a comma-separated list of HTML links to each address given in
573 $addresses, which should be a comma-separated list of RFC822
574 addresses. $urlfunc should be a reference to a function like mainturl
575 or submitterurl which returns the URL for each individual address.
580 sub htmlize_addresslinks {
581 my ($prefixfunc, $urlfunc, $addresses,$class) = @_;
582 carp "htmlize_addresslinks is deprecated";
584 $class = defined $class?qq(class="$class" ):'';
585 if (defined $addresses and $addresses ne '') {
586 my @addrs = getparsedaddrs($addresses);
587 my $prefix = (ref $prefixfunc) ?
588 $prefixfunc->(scalar @addrs):$prefixfunc;
591 { sprintf qq(<a ${class}).
593 $urlfunc->($_->address),
594 html_escape($_->format) ||
600 my $prefix = (ref $prefixfunc) ?
601 $prefixfunc->(1) : $prefixfunc;
602 return sprintf '%s<a '.$class.'href="%s">(unknown)</a>',
603 $prefix, $urlfunc->('');
608 my $addr = getparsedaddrs($_[0] || "");
609 $addr = defined $addr?$addr->address:'';
613 sub mainturl { package_links(maint => $_[0], links_only => 1); }
614 sub submitterurl { package_links(submitter => $_[0], links_only => 1); }
615 sub htmlize_maintlinks {
616 my ($prefixfunc, $maints) = @_;
617 carp "htmlize_maintlinks is deprecated";
618 return htmlize_addresslinks($prefixfunc, \&mainturl, $maints);
623 our $_maintainer_rev;
627 bug_linklist($separator,$class,@bugs)
629 Creates a set of links to C<@bugs> separated by C<$separator> with
630 link class C<$class>.
632 XXX Use L<Params::Validate>; we want to be able to support query
633 arguments here too; we should be able to combine bug_links and this
634 function into one. [Hell, bug_url should be one function with this one
641 my ($sep,$class,@bugs) = @_;
642 carp "bug_linklist is deprecated; use bug_links instead";
643 return scalar bug_links(bug=>\@bugs,class=>$class,separator=>$sep);
648 my ($user,$usertags,$bug_usertags,$seen_users,$cats,$hidden) = @_;
649 $seen_users = {} if not defined $seen_users;
650 $bug_usertags = {} if not defined $bug_usertags;
651 $usertags = {} if not defined $usertags;
652 $cats = {} if not defined $cats;
653 $hidden = {} if not defined $hidden;
654 return if exists $seen_users->{$user};
655 $seen_users->{$user} = 1;
657 my $u = Debbugs::User::get_user($user);
659 my %vis = map { $_, 1 } @{$u->{"visible_cats"}};
660 for my $c (keys %{$u->{"categories"}}) {
661 $cats->{$c} = $u->{"categories"}->{$c};
662 $hidden->{$c} = 1 unless defined $vis{$c};
664 for my $t (keys %{$u->{"tags"}}) {
665 $usertags->{$t} = [] unless defined $usertags->{$t};
666 push @{$usertags->{$t}}, @{$u->{"tags"}->{$t}};
669 %{$bug_usertags} = ();
670 for my $t (keys %{$usertags}) {
671 for my $b (@{$usertags->{$t}}) {
672 $bug_usertags->{$b} = [] unless defined $bug_usertags->{$b};
673 push @{$bug_usertags->{$b}}, $t;
684 =head2 form_options_and_normal_param
686 my ($form_option,$param) = form_options_and_normal_param(\%param)
687 if $param{form_options};
688 my $form_option = form_options_and_normal_param(\%param)
689 if $param{form_options};
691 Translates from special form_options to a set of parameters which can
692 be used to run the current page.
694 The idea behind this is to allow complex forms to relatively easily
695 cause options that the existing cgi scripts understand to be set.
697 Currently there are two commands which are understood:
698 combine, and concatenate.
702 Combine works by entering key,value pairs into the parameters using
703 the key field option input field, and the value field option input
706 For example, you would have
708 <input type="hidden" name="_fo_combine_key_fo_searchkey_value_fo_searchvalue" value="1">
710 which would combine the _fo_searchkey and _fo_searchvalue input fields, so
712 <input type="text" name="_fo_searchkey" value="foo">
713 <input type="text" name="_fo_searchvalue" value="bar">
715 would yield foo=>'bar' in %param.
719 Concatenate concatenates values into a single entry in a parameter
721 For example, you would have
723 <input type="hidden" name="_fo_concatentate_into_foo_with_:_fo_blah_fo_bleargh" value="1">
725 which would combine the _fo_searchkey and _fo_searchvalue input fields, so
727 <input type="text" name="_fo_blah" value="bar">
728 <input type="text" name="_fo_bleargh" value="baz">
730 would yield foo=>'bar:baz' in %param.
735 my $form_option_leader = '_fo_';
736 sub form_options_and_normal_param{
737 my ($orig_param) = @_;
738 # all form_option parameters start with _fo_
739 my ($param,$form_option) = ({},{});
740 for my $key (keys %{$orig_param}) {
741 if ($key =~ /^\Q$form_option_leader\E/) {
742 $form_option->{$key} = $orig_param->{$key};
745 $param->{$key} = $orig_param->{$key};
748 # at this point, we check for commands
749 COMMAND: for my $key (keys %{$form_option}) {
750 $key =~ s/^\Q$form_option_leader\E//;
751 if (my ($key_name,$value_name) =
752 $key =~ /combine_key(\Q$form_option_leader\E.+)
753 _value(\Q$form_option_leader\E.+)$/x
755 next unless defined $form_option->{$key_name};
756 next unless defined $form_option->{$value_name};
757 my @keys = make_list($form_option->{$key_name});
758 my @values = make_list($form_option->{$value_name});
759 for my $i (0 .. $#keys) {
760 last if $i > $#values;
761 next if not defined $keys[$i];
762 next if not defined $values[$i];
763 __add_to_param($param,
769 elsif (my ($field,$concatenate_key,$fields) =
770 $key =~ /concatenate_into_(.+?)((?:_with_[^_])?)
771 ((?:\Q$form_option_leader\E.+?)+)
774 if (length $concatenate_key) {
775 $concatenate_key =~ s/_with_//;
778 $concatenate_key = ':';
780 my @fields = $fields =~ m/(\Q$form_option_leader\E.+?)(?:(?=\Q$form_option_leader\E)|$)/g;
783 for my $f (@fields) {
784 next COMMAND unless defined $form_option->{$f};
785 $field_list{$f} = [make_list($form_option->{$f})];
786 $max_num = max($max_num,$#{$field_list{$f}});
788 for my $i (0 .. $max_num) {
789 next unless @fields == grep {$i <= $#{$field_list{$_}} and
790 defined $field_list{$_}[$i]} @fields;
791 __add_to_param($param,
793 join($concatenate_key,
794 map {$field_list{$_}[$i]} @fields
800 return wantarray?($form_option,$param):$form_option;
805 print option_form(template=>'pkgreport_options',
807 form_options => $form_options,
815 my %param = validate_with(params => \@_,
816 spec => {template => {type => SCALAR,
818 variables => {type => HASHREF,
821 language => {type => SCALAR,
824 param => {type => HASHREF,
827 form_options => {type => HASHREF,
833 # First, we need to see if we need to add particular types of
835 my $variables = dclone($param{variables});
836 $variables->{param} = dclone($param{param});
837 for my $key (keys %{$param{form_option}}) {
838 # strip out leader; shouldn't be anything here without one,
839 # but skip stupid things anyway
841 next unless $key =~ s/^\Q$form_option_leader\E//;
842 if ($key =~ /^add_(.+)$/) {
843 # this causes a specific parameter to be added
844 __add_to_param($variables->{param},
849 elsif ($key =~ /^delete_(.+?)(?:_(\d+))?$/) {
850 next unless exists $variables->{param}{$1};
851 if (ref $variables->{param}{$1} eq 'ARRAY' and
853 defined $variables->{param}{$1}[$2]
855 splice @{$variables->{param}{$1}},$2,1;
858 delete $variables->{param}{$1};
861 # we'll add extra comands here once I figure out what they
864 # add in a few utility routines
865 $variables->{output_select_options} = sub {
866 my ($options,$value) = @_;
867 my @options = @{$options};
869 while (my ($o_value,$name) = splice @options,0,2) {
871 if (defined $value and $o_value eq $value) {
872 $selected = ' selected';
874 $output .= q(<option value=").html_escape($o_value).qq("$selected>).
875 html_escape($name).qq(</option>\n);
879 $variables->{make_list} = sub { make_list(@_);
881 # now at this point, we're ready to create the template
882 return Debbugs::Text::fill_in_template(template=>$param{template},
883 (exists $param{language}?(language=>$param{language}):()),
884 variables => $variables,
885 hole_var => {'&html_escape' => \&html_escape,
891 my ($param,$key,@values) = @_;
893 if (exists $param->{$key} and not
894 ref $param->{$key}) {
895 @{$param->{$key}} = [$param->{$key},
900 push @{$param->{$key}}, @values;
914 Decodes the funky maintainer encoding.
916 Don't ask me what in the world it does.
922 return () unless @input;
924 for my $input (@input) {
925 my $decoded = $input;
926 $decoded =~ s/-([^_]+)/-$1_-/g;
927 $decoded =~ s/_/-20_/g;
928 $decoded =~ s/^,(.*),(.*),([^,]+)$/$1-40_$2-20_-28_$3-29_/;
929 $decoded =~ s/^([^,]+),(.*),(.*),/$1-20_-3c_$2-40_$3-3e_/;
930 $decoded =~ s/\./-2e_/g;
931 $decoded =~ s/-([0-9a-f]{2})_/pack('H*',$1)/ge;
932 push @output,$decoded;
934 wantarray ? @output : $output[0];