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 {(munge_url('pkgreport.cgi?',
407 ($type eq 'src'?'src:':'').$_);
408 } make_list($param{$type}) if exists $param{$type};
410 for my $type (qw(maint owner submitter correspondent)) {
411 push @links, map {my $addr = getparsedaddrs($_);
412 $addr = defined $addr?$addr->address:'';
413 (munge_url('pkgreport.cgi?',
418 } make_list($param{$type}) if exists $param{$type};
421 my ($link,$link_name);
423 if (length $param{class}) {
424 $class = q( class=").html_escape($param{class}).q(");
426 while (($link,$link_name) = splice(@links,0,2)) {
427 if ($param{links_only}) {
433 html_escape($link).q(">).
434 html_escape($link_name).q(</a>);
441 return join($param{separator},@return);
447 join(', ', bug_links(bug => \@packages))
449 Given a list of bugs, return a list of html which links to the bugs
453 =item bug -- arrayref or scalar of bug(s)
455 =item links_only -- return only links, not htmlized links, defaults to
456 returning htmlized links.
458 =item class -- class of the a href, defaults to ''
465 my %param = validate_with(params => \@_,
466 spec => {bug => {type => SCALAR|ARRAYREF,
469 links_only => {type => BOOLEAN,
472 class => {type => SCALAR,
475 separator => {type => SCALAR,
478 options => {type => HASHREF,
483 my %options = %{$param{options}};
486 delete $options{$_} if exists $options{$_};
489 push @links, map {(munge_url('bugreport.cgi?',
494 } make_list($param{bug}) if exists $param{bug};
496 my ($link,$link_name);
498 if (length $param{class}) {
499 $class = q( class=").html_escape($param{class}).q(");
501 while (($link,$link_name) = splice(@links,0,2)) {
502 if ($param{links_only}) {
508 html_escape($link).q(">).
509 html_escape($link_name).q(</a>);
516 return join($param{separator},@return);
525 maybelink('http://foobarbaz,http://bleh',qr/[, ]+/);
526 maybelink('http://foobarbaz,http://bleh',qr/[, ]+/,', ');
529 In the first form, links the link if it looks like a link. In the
530 second form, first splits based on the regex, then reassembles the
531 link, linking things that look like links. In the third form, rejoins
532 the split links with commas and spaces.
537 my ($links,$regex,$join) = @_;
538 if (not defined $regex and not defined $join) {
539 $links =~ s{(.*?)((?:(?:ftp|http|https)://[\S~-]+?/?)?)([\)\'\:\.\,]?(?:\s|\.<|$))}
540 {html_escape($1).(length $2?q(<a href=").html_escape($2).q(">).html_escape($2).q(</a>):'').html_escape($3)}geimo;
543 $join = ' ' if not defined $join;
546 if (defined $regex) {
547 @segments = split $regex, $links;
550 @segments = ($links);
552 for my $in (@segments) {
553 if ($in =~ /^[a-zA-Z0-9+.-]+:/) { # RFC 1738 scheme
554 push @return, qq{<a href="$in">} . html_escape($in) . '</a>';
556 push @return, html_escape($in);
559 return @return?join($join,@return):'';
563 =head2 htmlize_addresslinks
565 htmlize_addresslinks($prefixfunc,$urlfunc,$addresses,$class);
568 Generate a comma-separated list of HTML links to each address given in
569 $addresses, which should be a comma-separated list of RFC822
570 addresses. $urlfunc should be a reference to a function like mainturl
571 or submitterurl which returns the URL for each individual address.
576 sub htmlize_addresslinks {
577 my ($prefixfunc, $urlfunc, $addresses,$class) = @_;
578 carp "htmlize_addresslinks is deprecated";
580 $class = defined $class?qq(class="$class" ):'';
581 if (defined $addresses and $addresses ne '') {
582 my @addrs = getparsedaddrs($addresses);
583 my $prefix = (ref $prefixfunc) ?
584 $prefixfunc->(scalar @addrs):$prefixfunc;
587 { sprintf qq(<a ${class}).
589 $urlfunc->($_->address),
590 html_escape($_->format) ||
596 my $prefix = (ref $prefixfunc) ?
597 $prefixfunc->(1) : $prefixfunc;
598 return sprintf '%s<a '.$class.'href="%s">(unknown)</a>',
599 $prefix, $urlfunc->('');
604 my $addr = getparsedaddrs($_[0] || "");
605 $addr = defined $addr?$addr->address:'';
609 sub mainturl { package_links(maint => $_[0], links_only => 1); }
610 sub submitterurl { package_links(submitter => $_[0], links_only => 1); }
611 sub htmlize_maintlinks {
612 my ($prefixfunc, $maints) = @_;
613 carp "htmlize_maintlinks is deprecated";
614 return htmlize_addresslinks($prefixfunc, \&mainturl, $maints);
619 our $_maintainer_rev;
623 bug_linklist($separator,$class,@bugs)
625 Creates a set of links to C<@bugs> separated by C<$separator> with
626 link class C<$class>.
628 XXX Use L<Params::Validate>; we want to be able to support query
629 arguments here too; we should be able to combine bug_links and this
630 function into one. [Hell, bug_url should be one function with this one
637 my ($sep,$class,@bugs) = @_;
638 carp "bug_linklist is deprecated; use bug_links instead";
639 return scalar bug_links(bug=>\@bugs,class=>$class,separator=>$sep);
644 my ($user,$usertags,$bug_usertags,$seen_users,$cats,$hidden) = @_;
645 $seen_users = {} if not defined $seen_users;
646 $bug_usertags = {} if not defined $bug_usertags;
647 $usertags = {} if not defined $usertags;
648 $cats = {} if not defined $cats;
649 $hidden = {} if not defined $hidden;
650 return if exists $seen_users->{$user};
651 $seen_users->{$user} = 1;
653 my $u = Debbugs::User::get_user($user);
655 my %vis = map { $_, 1 } @{$u->{"visible_cats"}};
656 for my $c (keys %{$u->{"categories"}}) {
657 $cats->{$c} = $u->{"categories"}->{$c};
658 $hidden->{$c} = 1 unless defined $vis{$c};
660 for my $t (keys %{$u->{"tags"}}) {
661 $usertags->{$t} = [] unless defined $usertags->{$t};
662 push @{$usertags->{$t}}, @{$u->{"tags"}->{$t}};
665 %{$bug_usertags} = ();
666 for my $t (keys %{$usertags}) {
667 for my $b (@{$usertags->{$t}}) {
668 $bug_usertags->{$b} = [] unless defined $bug_usertags->{$b};
669 push @{$bug_usertags->{$b}}, $t;
680 =head2 form_options_and_normal_param
682 my ($form_option,$param) = form_options_and_normal_param(\%param)
683 if $param{form_options};
684 my $form_option = form_options_and_normal_param(\%param)
685 if $param{form_options};
687 Translates from special form_options to a set of parameters which can
688 be used to run the current page.
690 The idea behind this is to allow complex forms to relatively easily
691 cause options that the existing cgi scripts understand to be set.
693 Currently there are two commands which are understood:
694 combine, and concatenate.
698 Combine works by entering key,value pairs into the parameters using
699 the key field option input field, and the value field option input
702 For example, you would have
704 <input type="hidden" name="_fo_combine_key_fo_searchkey_value_fo_searchvalue" value="1">
706 which would combine the _fo_searchkey and _fo_searchvalue input fields, so
708 <input type="text" name="_fo_searchkey" value="foo">
709 <input type="text" name="_fo_searchvalue" value="bar">
711 would yield foo=>'bar' in %param.
715 Concatenate concatenates values into a single entry in a parameter
717 For example, you would have
719 <input type="hidden" name="_fo_concatentate_into_foo_with_:_fo_blah_fo_bleargh" value="1">
721 which would combine the _fo_searchkey and _fo_searchvalue input fields, so
723 <input type="text" name="_fo_blah" value="bar">
724 <input type="text" name="_fo_bleargh" value="baz">
726 would yield foo=>'bar:baz' in %param.
731 my $form_option_leader = '_fo_';
732 sub form_options_and_normal_param{
733 my ($orig_param) = @_;
734 # all form_option parameters start with _fo_
735 my ($param,$form_option) = ({},{});
736 for my $key (keys %{$orig_param}) {
737 if ($key =~ /^\Q$form_option_leader\E/) {
738 $form_option->{$key} = $orig_param->{$key};
741 $param->{$key} = $orig_param->{$key};
744 # at this point, we check for commands
745 COMMAND: for my $key (keys %{$form_option}) {
746 $key =~ s/^\Q$form_option_leader\E//;
747 if (my ($key_name,$value_name) =
748 $key =~ /combine_key(\Q$form_option_leader\E.+)
749 _value(\Q$form_option_leader\E.+)$/x
751 next unless defined $form_option->{$key_name};
752 next unless defined $form_option->{$value_name};
753 my @keys = make_list($form_option->{$key_name});
754 my @values = make_list($form_option->{$value_name});
755 for my $i (0 .. $#keys) {
756 last if $i > $#values;
757 next if not defined $keys[$i];
758 next if not defined $values[$i];
759 __add_to_param($param,
765 elsif (my ($field,$concatenate_key,$fields) =
766 $key =~ /concatenate_into_(.+?)((?:_with_[^_])?)
767 ((?:\Q$form_option_leader\E.+?)+)
770 if (length $concatenate_key) {
771 $concatenate_key =~ s/_with_//;
774 $concatenate_key = ':';
776 my @fields = $fields =~ m/(\Q$form_option_leader\E.+?)(?:(?=\Q$form_option_leader\E)|$)/g;
779 for my $f (@fields) {
780 next COMMAND unless defined $form_option->{$f};
781 $field_list{$f} = [make_list($form_option->{$f})];
782 $max_num = max($max_num,$#{$field_list{$f}});
784 for my $i (0 .. $max_num) {
785 next unless @fields == grep {$i <= $#{$field_list{$_}} and
786 defined $field_list{$_}[$i]} @fields;
787 __add_to_param($param,
789 join($concatenate_key,
790 map {$field_list{$_}[$i]} @fields
796 return wantarray?($form_option,$param):$form_option;
801 print option_form(template=>'pkgreport_options',
803 form_options => $form_options,
811 my %param = validate_with(params => \@_,
812 spec => {template => {type => SCALAR,
814 variables => {type => HASHREF,
817 language => {type => SCALAR,
820 param => {type => HASHREF,
823 form_options => {type => HASHREF,
829 # First, we need to see if we need to add particular types of
831 my $variables = dclone($param{variables});
832 $variables->{param} = dclone($param{param});
833 for my $key (keys %{$param{form_option}}) {
834 # strip out leader; shouldn't be anything here without one,
835 # but skip stupid things anyway
837 next unless $key =~ s/^\Q$form_option_leader\E//;
838 if ($key =~ /^add_(.+)$/) {
839 # this causes a specific parameter to be added
840 __add_to_param($variables->{param},
845 elsif ($key =~ /^delete_(.+?)(?:_(\d+))?$/) {
846 next unless exists $variables->{param}{$1};
847 if (ref $variables->{param}{$1} eq 'ARRAY' and
849 defined $variables->{param}{$1}[$2]
851 splice @{$variables->{param}{$1}},$2,1;
854 delete $variables->{param}{$1};
857 # we'll add extra comands here once I figure out what they
860 # add in a few utility routines
861 $variables->{output_select_options} = sub {
862 my ($options,$value) = @_;
863 my @options = @{$options};
865 while (my ($o_value,$name) = splice @options,0,2) {
867 if (defined $value and $o_value eq $value) {
868 $selected = ' selected';
870 $output .= q(<option value=").html_escape($o_value).qq("$selected>).
871 html_escape($name).qq(</option>\n);
875 $variables->{make_list} = sub { make_list(@_);
877 # now at this point, we're ready to create the template
878 return Debbugs::Text::fill_in_template(template=>$param{template},
879 (exists $param{language}?(language=>$param{language}):()),
880 variables => $variables,
881 hole_var => {'&html_escape' => \&html_escape,
887 my ($param,$key,@values) = @_;
889 if (exists $param->{$key} and not
890 ref $param->{$key}) {
891 @{$param->{$key}} = [$param->{$key},
896 push @{$param->{$key}}, @values;
910 Decodes the funky maintainer encoding.
912 Don't ask me what in the world it does.
918 return () unless @input;
920 for my $input (@input) {
921 my $decoded = $input;
922 $decoded =~ s/-([^_]+)/-$1_-/g;
923 $decoded =~ s/_/-20_/g;
924 $decoded =~ s/^,(.*),(.*),([^,]+)$/$1-40_$2-20_-28_$3-29_/;
925 $decoded =~ s/^([^,]+),(.*),(.*),/$1-20_-3c_$2-40_$3-3e_/;
926 $decoded =~ s/\./-2e_/g;
927 $decoded =~ s/-([0-9a-f]{2})_/pack('H*',$1)/ge;
928 push @output,$decoded;
930 wantarray ? @output : $output[0];