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,
165 map {($_,$params{$_})}
167 return $new_url->as_string;
173 version_url(package => $package,found => $found,fixed => $fixed)
175 Creates a link to the version cgi script
179 =item package -- source package whose graph to display
181 =item found -- arrayref of found versions
183 =item fixed -- arrayref of fixed versions
185 =item width -- optional width of graph
187 =item height -- optional height of graph
189 =item info -- display html info surrounding graph; defaults to 1 if
190 width and height are not passed.
192 =item collapse -- whether to collapse the graph; defaults to 1 if
193 width and height are passed.
200 my %params = validate_with(params => \@_,
201 spec => {package => {type => SCALAR|ARRAYREF,
203 found => {type => ARRAYREF,
206 fixed => {type => ARRAYREF,
209 width => {type => SCALAR,
212 height => {type => SCALAR,
215 absolute => {type => BOOLEAN,
218 collapse => {type => BOOLEAN,
221 info => {type => BOOLEAN,
226 if (not defined $params{width} and not defined $params{height}) {
227 $params{info} = 1 if not exists $params{info};
229 my $url = Debbugs::URI->new('version.cgi?');
230 $url->query_form(%params);
231 return $url->as_string;
238 Escapes html entities by calling HTML::Entities::encode_entities;
245 return HTML::Entities::encode_entities($string,q(<>&"'));
248 =head2 cgi_parameters
252 Returns all of the cgi_parameters from a CGI script using CGI::Simple
257 my %options = validate_with(params => \@_,
258 spec => {query => {type => OBJECT,
261 single => {type => ARRAYREF,
264 default => {type => HASHREF,
269 my $q = $options{query};
271 @single{@{$options{single}}} = (1) x @{$options{single}};
273 for my $paramname ($q->param) {
274 if ($single{$paramname}) {
275 $param{$paramname} = $q->param($paramname);
278 $param{$paramname} = [$q->param($paramname)];
281 for my $default (keys %{$options{default}}) {
282 if (not exists $param{$default}) {
283 # We'll clone the reference here to avoid surprises later.
284 $param{$default} = ref($options{default}{$default})?
285 dclone($options{default}{$default}):$options{default}{$default};
294 print "Content-Type: text/html\n\n";
295 print fill_in_template(template=>'cgi/quit',
296 variables => {msg => $msg}
304 =head2 htmlize_packagelinks
308 Given a scalar containing a list of packages separated by something
309 that L<Debbugs::CGI/splitpackages> can separate, returns a
310 formatted set of links to packages in html.
314 sub htmlize_packagelinks {
316 return '' unless defined $pkgs and $pkgs ne '';
317 my @pkglist = splitpackages($pkgs);
319 carp "htmlize_packagelinks is deprecated, use package_links instead";
321 return 'Package' . (@pkglist > 1 ? 's' : '') . ': ' .
322 package_links(package =>\@pkglist,
329 join(', ', package_links(packages => \@packages))
331 Given a list of packages, return a list of html which links to the package
335 =item package -- arrayref or scalar of package(s)
337 =item submitter -- arrayref or scalar of submitter(s)
339 =item src -- arrayref or scalar of source(s)
341 =item maintainer -- arrayref or scalar of maintainer(s)
343 =item links_only -- return only links, not htmlized links, defaults to
344 returning htmlized links.
346 =item class -- class of the a href, defaults to ''
352 our @package_search_key_order = (package => 'in package',
354 severity => 'with severity',
355 src => 'in source package',
356 maint => 'in packages maintained by',
357 submitter => 'submitted by',
359 status => 'with status',
360 affects => 'which affect package',
361 correspondent => 'with mail from',
362 newest => 'newest bugs',
365 our %package_search_keys = @package_search_key_order;
369 my %param = validate_with(params => \@_,
370 spec => {(map { ($_,{type => SCALAR|ARRAYREF,
373 } keys %package_search_keys,
375 links_only => {type => BOOLEAN,
378 class => {type => SCALAR,
381 separator => {type => SCALAR,
384 options => {type => HASHREF,
391 my %map = (source => 'src',
392 maintainer => 'maint',
395 return $map{$key} if exists $map{$key};
399 my %options = %{$param{options}};
400 for ((keys %package_search_keys,qw(msg att))) {
401 delete $options{$_} if exists $options{$_};
404 for my $type (qw(src package)) {
405 push @links, map {my $t_type = $type;
406 if ($_ =~ s/^src://) {
409 (munge_url('pkgreport.cgi?',
413 ($t_type eq 'src'?'src:':'').$_);
414 } make_list($param{$type}) if exists $param{$type};
416 for my $type (qw(maint owner submitter correspondent)) {
417 push @links, map {my $addr = getparsedaddrs($_);
418 $addr = defined $addr?$addr->address:'';
419 (munge_url('pkgreport.cgi?',
424 } make_list($param{$type}) if exists $param{$type};
427 my ($link,$link_name);
429 if (length $param{class}) {
430 $class = q( class=").html_escape($param{class}).q(");
432 while (($link,$link_name) = splice(@links,0,2)) {
433 if ($param{links_only}) {
439 html_escape($link).q(">).
440 html_escape($link_name).q(</a>);
447 return join($param{separator},@return);
453 join(', ', bug_links(bug => \@packages))
455 Given a list of bugs, return a list of html which links to the bugs
459 =item bug -- arrayref or scalar of bug(s)
461 =item links_only -- return only links, not htmlized links, defaults to
462 returning htmlized links.
464 =item class -- class of the a href, defaults to ''
471 my %param = validate_with(params => \@_,
472 spec => {bug => {type => SCALAR|ARRAYREF,
475 links_only => {type => BOOLEAN,
478 class => {type => SCALAR,
481 separator => {type => SCALAR,
484 options => {type => HASHREF,
489 my %options = %{$param{options}};
492 delete $options{$_} if exists $options{$_};
495 push @links, map {(munge_url('bugreport.cgi?',
500 } make_list($param{bug}) if exists $param{bug};
502 my ($link,$link_name);
504 if (length $param{class}) {
505 $class = q( class=").html_escape($param{class}).q(");
507 while (($link,$link_name) = splice(@links,0,2)) {
508 if ($param{links_only}) {
514 html_escape($link).q(">).
515 html_escape($link_name).q(</a>);
522 return join($param{separator},@return);
531 maybelink('http://foobarbaz,http://bleh',qr/[, ]+/);
532 maybelink('http://foobarbaz,http://bleh',qr/[, ]+/,', ');
535 In the first form, links the link if it looks like a link. In the
536 second form, first splits based on the regex, then reassembles the
537 link, linking things that look like links. In the third form, rejoins
538 the split links with commas and spaces.
543 my ($links,$regex,$join) = @_;
544 if (not defined $regex and not defined $join) {
545 $links =~ s{(.*?)((?:(?:ftp|http|https)://[\S~-]+?/?)?)([\)\'\:\.\,]?(?:\s|\.<|$))}
546 {html_escape($1).(length $2?q(<a href=").html_escape($2).q(">).html_escape($2).q(</a>):'').html_escape($3)}geimo;
549 $join = ' ' if not defined $join;
552 if (defined $regex) {
553 @segments = split $regex, $links;
556 @segments = ($links);
558 for my $in (@segments) {
559 if ($in =~ /^[a-zA-Z0-9+.-]+:/) { # RFC 1738 scheme
560 push @return, qq{<a href="$in">} . html_escape($in) . '</a>';
562 push @return, html_escape($in);
565 return @return?join($join,@return):'';
569 =head2 htmlize_addresslinks
571 htmlize_addresslinks($prefixfunc,$urlfunc,$addresses,$class);
574 Generate a comma-separated list of HTML links to each address given in
575 $addresses, which should be a comma-separated list of RFC822
576 addresses. $urlfunc should be a reference to a function like mainturl
577 or submitterurl which returns the URL for each individual address.
582 sub htmlize_addresslinks {
583 my ($prefixfunc, $urlfunc, $addresses,$class) = @_;
584 carp "htmlize_addresslinks is deprecated";
586 $class = defined $class?qq(class="$class" ):'';
587 if (defined $addresses and $addresses ne '') {
588 my @addrs = getparsedaddrs($addresses);
589 my $prefix = (ref $prefixfunc) ?
590 $prefixfunc->(scalar @addrs):$prefixfunc;
593 { sprintf qq(<a ${class}).
595 $urlfunc->($_->address),
596 html_escape($_->format) ||
602 my $prefix = (ref $prefixfunc) ?
603 $prefixfunc->(1) : $prefixfunc;
604 return sprintf '%s<a '.$class.'href="%s">(unknown)</a>',
605 $prefix, $urlfunc->('');
610 my $addr = getparsedaddrs($_[0] || "");
611 $addr = defined $addr?$addr->address:'';
615 sub mainturl { package_links(maint => $_[0], links_only => 1); }
616 sub submitterurl { package_links(submitter => $_[0], links_only => 1); }
617 sub htmlize_maintlinks {
618 my ($prefixfunc, $maints) = @_;
619 carp "htmlize_maintlinks is deprecated";
620 return htmlize_addresslinks($prefixfunc, \&mainturl, $maints);
625 our $_maintainer_rev;
629 bug_linklist($separator,$class,@bugs)
631 Creates a set of links to C<@bugs> separated by C<$separator> with
632 link class C<$class>.
634 XXX Use L<Params::Validate>; we want to be able to support query
635 arguments here too; we should be able to combine bug_links and this
636 function into one. [Hell, bug_url should be one function with this one
643 my ($sep,$class,@bugs) = @_;
644 carp "bug_linklist is deprecated; use bug_links instead";
645 return scalar bug_links(bug=>\@bugs,class=>$class,separator=>$sep);
650 my ($user,$usertags,$bug_usertags,$seen_users,$cats,$hidden) = @_;
651 $seen_users = {} if not defined $seen_users;
652 $bug_usertags = {} if not defined $bug_usertags;
653 $usertags = {} if not defined $usertags;
654 $cats = {} if not defined $cats;
655 $hidden = {} if not defined $hidden;
656 return if exists $seen_users->{$user};
657 $seen_users->{$user} = 1;
659 my $u = Debbugs::User::get_user($user);
661 my %vis = map { $_, 1 } @{$u->{"visible_cats"}};
662 for my $c (keys %{$u->{"categories"}}) {
663 $cats->{$c} = $u->{"categories"}->{$c};
664 $hidden->{$c} = 1 unless defined $vis{$c};
666 for my $t (keys %{$u->{"tags"}}) {
667 $usertags->{$t} = [] unless defined $usertags->{$t};
668 push @{$usertags->{$t}}, @{$u->{"tags"}->{$t}};
671 %{$bug_usertags} = ();
672 for my $t (keys %{$usertags}) {
673 for my $b (@{$usertags->{$t}}) {
674 $bug_usertags->{$b} = [] unless defined $bug_usertags->{$b};
675 push @{$bug_usertags->{$b}}, $t;
686 =head2 form_options_and_normal_param
688 my ($form_option,$param) = form_options_and_normal_param(\%param)
689 if $param{form_options};
690 my $form_option = form_options_and_normal_param(\%param)
691 if $param{form_options};
693 Translates from special form_options to a set of parameters which can
694 be used to run the current page.
696 The idea behind this is to allow complex forms to relatively easily
697 cause options that the existing cgi scripts understand to be set.
699 Currently there are two commands which are understood:
700 combine, and concatenate.
704 Combine works by entering key,value pairs into the parameters using
705 the key field option input field, and the value field option input
708 For example, you would have
710 <input type="hidden" name="_fo_combine_key_fo_searchkey_value_fo_searchvalue" value="1">
712 which would combine the _fo_searchkey and _fo_searchvalue input fields, so
714 <input type="text" name="_fo_searchkey" value="foo">
715 <input type="text" name="_fo_searchvalue" value="bar">
717 would yield foo=>'bar' in %param.
721 Concatenate concatenates values into a single entry in a parameter
723 For example, you would have
725 <input type="hidden" name="_fo_concatentate_into_foo_with_:_fo_blah_fo_bleargh" value="1">
727 which would combine the _fo_searchkey and _fo_searchvalue input fields, so
729 <input type="text" name="_fo_blah" value="bar">
730 <input type="text" name="_fo_bleargh" value="baz">
732 would yield foo=>'bar:baz' in %param.
737 my $form_option_leader = '_fo_';
738 sub form_options_and_normal_param{
739 my ($orig_param) = @_;
740 # all form_option parameters start with _fo_
741 my ($param,$form_option) = ({},{});
742 for my $key (keys %{$orig_param}) {
743 if ($key =~ /^\Q$form_option_leader\E/) {
744 $form_option->{$key} = $orig_param->{$key};
747 $param->{$key} = $orig_param->{$key};
750 # at this point, we check for commands
751 COMMAND: for my $key (keys %{$form_option}) {
752 $key =~ s/^\Q$form_option_leader\E//;
753 if (my ($key_name,$value_name) =
754 $key =~ /combine_key(\Q$form_option_leader\E.+)
755 _value(\Q$form_option_leader\E.+)$/x
757 next unless defined $form_option->{$key_name};
758 next unless defined $form_option->{$value_name};
759 my @keys = make_list($form_option->{$key_name});
760 my @values = make_list($form_option->{$value_name});
761 for my $i (0 .. $#keys) {
762 last if $i > $#values;
763 next if not defined $keys[$i];
764 next if not defined $values[$i];
765 __add_to_param($param,
771 elsif (my ($field,$concatenate_key,$fields) =
772 $key =~ /concatenate_into_(.+?)((?:_with_[^_])?)
773 ((?:\Q$form_option_leader\E.+?)+)
776 if (length $concatenate_key) {
777 $concatenate_key =~ s/_with_//;
780 $concatenate_key = ':';
782 my @fields = $fields =~ m/(\Q$form_option_leader\E.+?)(?:(?=\Q$form_option_leader\E)|$)/g;
785 for my $f (@fields) {
786 next COMMAND unless defined $form_option->{$f};
787 $field_list{$f} = [make_list($form_option->{$f})];
788 $max_num = max($max_num,$#{$field_list{$f}});
790 for my $i (0 .. $max_num) {
791 next unless @fields == grep {$i <= $#{$field_list{$_}} and
792 defined $field_list{$_}[$i]} @fields;
793 __add_to_param($param,
795 join($concatenate_key,
796 map {$field_list{$_}[$i]} @fields
802 return wantarray?($form_option,$param):$form_option;
807 print option_form(template=>'pkgreport_options',
809 form_options => $form_options,
817 my %param = validate_with(params => \@_,
818 spec => {template => {type => SCALAR,
820 variables => {type => HASHREF,
823 language => {type => SCALAR,
826 param => {type => HASHREF,
829 form_options => {type => HASHREF,
835 # First, we need to see if we need to add particular types of
837 my $variables = dclone($param{variables});
838 $variables->{param} = dclone($param{param});
839 for my $key (keys %{$param{form_option}}) {
840 # strip out leader; shouldn't be anything here without one,
841 # but skip stupid things anyway
843 next unless $key =~ s/^\Q$form_option_leader\E//;
844 if ($key =~ /^add_(.+)$/) {
845 # this causes a specific parameter to be added
846 __add_to_param($variables->{param},
851 elsif ($key =~ /^delete_(.+?)(?:_(\d+))?$/) {
852 next unless exists $variables->{param}{$1};
853 if (ref $variables->{param}{$1} eq 'ARRAY' and
855 defined $variables->{param}{$1}[$2]
857 splice @{$variables->{param}{$1}},$2,1;
860 delete $variables->{param}{$1};
863 # we'll add extra comands here once I figure out what they
866 # add in a few utility routines
867 $variables->{output_select_options} = sub {
868 my ($options,$value) = @_;
869 my @options = @{$options};
871 while (my ($o_value,$name) = splice @options,0,2) {
873 if (defined $value and $o_value eq $value) {
874 $selected = ' selected';
876 $output .= q(<option value=").html_escape($o_value).qq("$selected>).
877 html_escape($name).qq(</option>\n);
881 $variables->{make_list} = sub { make_list(@_);
883 # now at this point, we're ready to create the template
884 return Debbugs::Text::fill_in_template(template=>$param{template},
885 (exists $param{language}?(language=>$param{language}):()),
886 variables => $variables,
887 hole_var => {'&html_escape' => \&html_escape,
893 my ($param,$key,@values) = @_;
895 if (exists $param->{$key} and not
896 ref $param->{$key}) {
897 @{$param->{$key}} = [$param->{$key},
902 push @{$param->{$key}}, @values;
916 Decodes the funky maintainer encoding.
918 Don't ask me what in the world it does.
924 return () unless @input;
926 for my $input (@input) {
927 my $decoded = $input;
928 $decoded =~ s/-([^_]+)/-$1_-/g;
929 $decoded =~ s/_/-20_/g;
930 $decoded =~ s/^,(.*),(.*),([^,]+)$/$1-40_$2-20_-28_$3-29_/;
931 $decoded =~ s/^([^,]+),(.*),(.*),/$1-20_-3c_$2-40_$3-3e_/;
932 $decoded =~ s/\./-2e_/g;
933 $decoded =~ s/-([0-9a-f]{2})_/pack('H*',$1)/ge;
934 push @output,$decoded;
936 wantarray ? @output : $output[0];