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 affects => 'which affect package',
354 correspondent => 'with mail from',
355 newest => 'newest bugs',
358 our %package_search_keys = @package_search_key_order;
362 my %param = validate_with(params => \@_,
363 spec => {(map { ($_,{type => SCALAR|ARRAYREF,
366 } keys %package_search_keys,
368 links_only => {type => BOOLEAN,
371 class => {type => SCALAR,
374 separator => {type => SCALAR,
377 options => {type => HASHREF,
384 my %map = (source => 'src',
385 maintainer => 'maint',
388 return $map{$key} if exists $map{$key};
392 my %options = %{$param{options}};
393 for ((keys %package_search_keys,qw(msg att))) {
394 delete $options{$_} if exists $options{$_};
397 for my $type (qw(src package)) {
398 push @links, map {(munge_url('pkgreport.cgi?',
403 } make_list($param{$type}) if exists $param{$type};
405 for my $type (qw(maint owner submitter correspondent)) {
406 push @links, map {my $addr = getparsedaddrs($_);
407 $addr = defined $addr?$addr->address:'';
408 (munge_url('pkgreport.cgi?',
413 } make_list($param{$type}) if exists $param{$type};
416 my ($link,$link_name);
418 if (length $param{class}) {
419 $class = q( class=").html_escape($param{class}).q(");
421 while (($link,$link_name) = splice(@links,0,2)) {
422 if ($param{links_only}) {
428 html_escape($link).q(">).
429 html_escape($link_name).q(</a>);
436 return join($param{separator},@return);
442 join(', ', bug_links(bug => \@packages))
444 Given a list of bugs, return a list of html which links to the bugs
448 =item bug -- arrayref or scalar of bug(s)
450 =item links_only -- return only links, not htmlized links, defaults to
451 returning htmlized links.
453 =item class -- class of the a href, defaults to ''
460 my %param = validate_with(params => \@_,
461 spec => {bug => {type => SCALAR|ARRAYREF,
464 links_only => {type => BOOLEAN,
467 class => {type => SCALAR,
470 separator => {type => SCALAR,
473 options => {type => HASHREF,
478 my %options = %{$param{options}};
481 delete $options{$_} if exists $options{$_};
484 push @links, map {(munge_url('bugreport.cgi?',
489 } make_list($param{bug}) if exists $param{bug};
491 my ($link,$link_name);
493 if (length $param{class}) {
494 $class = q( class=").html_escape($param{class}).q(");
496 while (($link,$link_name) = splice(@links,0,2)) {
497 if ($param{links_only}) {
503 html_escape($link).q(">).
504 html_escape($link_name).q(</a>);
511 return join($param{separator},@return);
520 maybelink('http://foobarbaz,http://bleh',qr/[, ]+/);
521 maybelink('http://foobarbaz,http://bleh',qr/[, ]+/,', ');
524 In the first form, links the link if it looks like a link. In the
525 second form, first splits based on the regex, then reassembles the
526 link, linking things that look like links. In the third form, rejoins
527 the split links with commas and spaces.
532 my ($links,$regex,$join) = @_;
533 if (not defined $regex and not defined $join) {
534 $links =~ s{((?:ftp|http|https)://[\S~-]+?/?)([\)\'\:\.\,]?(?:\s|\.<|$))}
535 {q(<a href=\").html_escape($1).q(\">).html_escape($1).q(</a>).$2}geimo;
538 $join = ' ' if not defined $join;
541 if (defined $regex) {
542 @segments = split $regex, $links;
545 @segments = ($links);
547 for my $in (@segments) {
548 if ($in =~ /^[a-zA-Z0-9+.-]+:/) { # RFC 1738 scheme
549 push @return, qq{<a href="$in">} . html_escape($in) . '</a>';
551 push @return, html_escape($in);
554 return @return?join($join,@return):'';
558 =head2 htmlize_addresslinks
560 htmlize_addresslinks($prefixfunc,$urlfunc,$addresses,$class);
563 Generate a comma-separated list of HTML links to each address given in
564 $addresses, which should be a comma-separated list of RFC822
565 addresses. $urlfunc should be a reference to a function like mainturl
566 or submitterurl which returns the URL for each individual address.
571 sub htmlize_addresslinks {
572 my ($prefixfunc, $urlfunc, $addresses,$class) = @_;
573 carp "htmlize_addresslinks is deprecated";
575 $class = defined $class?qq(class="$class" ):'';
576 if (defined $addresses and $addresses ne '') {
577 my @addrs = getparsedaddrs($addresses);
578 my $prefix = (ref $prefixfunc) ?
579 $prefixfunc->(scalar @addrs):$prefixfunc;
582 { sprintf qq(<a ${class}).
584 $urlfunc->($_->address),
585 html_escape($_->format) ||
591 my $prefix = (ref $prefixfunc) ?
592 $prefixfunc->(1) : $prefixfunc;
593 return sprintf '%s<a '.$class.'href="%s">(unknown)</a>',
594 $prefix, $urlfunc->('');
599 my $addr = getparsedaddrs($_[0] || "");
600 $addr = defined $addr?$addr->address:'';
604 sub mainturl { package_links(maint => $_[0], links_only => 1); }
605 sub submitterurl { package_links(submitter => $_[0], links_only => 1); }
606 sub htmlize_maintlinks {
607 my ($prefixfunc, $maints) = @_;
608 carp "htmlize_maintlinks is deprecated";
609 return htmlize_addresslinks($prefixfunc, \&mainturl, $maints);
614 our $_maintainer_rev;
618 bug_linklist($separator,$class,@bugs)
620 Creates a set of links to C<@bugs> separated by C<$separator> with
621 link class C<$class>.
623 XXX Use L<Params::Validate>; we want to be able to support query
624 arguments here too; we should be able to combine bug_links and this
625 function into one. [Hell, bug_url should be one function with this one
632 my ($sep,$class,@bugs) = @_;
633 carp "bug_linklist is deprecated; use bug_links instead";
634 return scalar bug_links(bug=>\@bugs,class=>$class,separator=>$sep);
643 =head2 form_options_and_normal_param
645 my ($form_option,$param) = form_options_and_normal_param(\%param)
646 if $param{form_options};
647 my $form_option = form_options_and_normal_param(\%param)
648 if $param{form_options};
650 Translates from special form_options to a set of parameters which can
651 be used to run the current page.
653 The idea behind this is to allow complex forms to relatively easily
654 cause options that the existing cgi scripts understand to be set.
656 Currently there are two commands which are understood:
657 combine, and concatenate.
661 Combine works by entering key,value pairs into the parameters using
662 the key field option input field, and the value field option input
665 For example, you would have
667 <input type="hidden" name="_fo_combine_key_fo_searchkey_value_fo_searchvalue" value="1">
669 which would combine the _fo_searchkey and _fo_searchvalue input fields, so
671 <input type="text" name="_fo_searchkey" value="foo">
672 <input type="text" name="_fo_searchvalue" value="bar">
674 would yield foo=>'bar' in %param.
678 Concatenate concatenates values into a single entry in a parameter
680 For example, you would have
682 <input type="hidden" name="_fo_concatentate_into_foo_with_:_fo_blah_fo_bleargh" value="1">
684 which would combine the _fo_searchkey and _fo_searchvalue input fields, so
686 <input type="text" name="_fo_blah" value="bar">
687 <input type="text" name="_fo_bleargh" value="baz">
689 would yield foo=>'bar:baz' in %param.
694 my $form_option_leader = '_fo_';
695 sub form_options_and_normal_param{
696 my ($orig_param) = @_;
697 # all form_option parameters start with _fo_
698 my ($param,$form_option) = ({},{});
699 for my $key (keys %{$orig_param}) {
700 if ($key =~ /^\Q$form_option_leader\E/) {
701 $form_option->{$key} = $orig_param->{$key};
704 $param->{$key} = $orig_param->{$key};
707 # at this point, we check for commands
708 COMMAND: for my $key (keys %{$form_option}) {
709 $key =~ s/^\Q$form_option_leader\E//;
710 if (my ($key_name,$value_name) =
711 $key =~ /combine_key(\Q$form_option_leader\E.+)
712 _value(\Q$form_option_leader\E.+)$/x
714 next unless defined $form_option->{$key_name};
715 next unless defined $form_option->{$value_name};
716 my @keys = make_list($form_option->{$key_name});
717 my @values = make_list($form_option->{$value_name});
718 for my $i (0 .. $#keys) {
719 last if $i > $#values;
720 next if not defined $keys[$i];
721 next if not defined $values[$i];
722 __add_to_param($param,
728 elsif (my ($field,$concatenate_key,$fields) =
729 $key =~ /concatenate_into_(.+?)((?:_with_[^_])?)
730 ((?:\Q$form_option_leader\E.+?)+)
733 if (length $concatenate_key) {
734 $concatenate_key =~ s/_with_//;
737 $concatenate_key = ':';
739 my @fields = $fields =~ m/(\Q$form_option_leader\E.+?)(?:(?=\Q$form_option_leader\E)|$)/g;
742 for my $f (@fields) {
743 next COMMAND unless defined $form_option->{$f};
744 $field_list{$f} = [make_list($form_option->{$f})];
745 $max_num = max($max_num,$#{$field_list{$f}});
747 for my $i (0 .. $max_num) {
748 next unless @fields == grep {$i <= $#{$field_list{$_}} and
749 defined $field_list{$_}[$i]} @fields;
750 __add_to_param($param,
752 join($concatenate_key,
753 map {$field_list{$_}[$i]} @fields
759 return wantarray?($form_option,$param):$form_option;
764 print option_form(template=>'pkgreport_options',
766 form_options => $form_options,
774 my %param = validate_with(params => \@_,
775 spec => {template => {type => SCALAR,
777 variables => {type => HASHREF,
780 language => {type => SCALAR,
783 param => {type => HASHREF,
786 form_options => {type => HASHREF,
792 # First, we need to see if we need to add particular types of
794 my $variables = dclone($param{variables});
795 $variables->{param} = dclone($param{param});
796 for my $key (keys %{$param{form_option}}) {
797 # strip out leader; shouldn't be anything here without one,
798 # but skip stupid things anyway
800 next unless $key =~ s/^\Q$form_option_leader\E//;
801 if ($key =~ /^add_(.+)$/) {
802 # this causes a specific parameter to be added
803 __add_to_param($variables->{param},
808 elsif ($key =~ /^delete_(.+?)(?:_(\d+))?$/) {
809 next unless exists $variables->{param}{$1};
810 if (ref $variables->{param}{$1} eq 'ARRAY' and
812 defined $variables->{param}{$1}[$2]
814 splice @{$variables->{param}{$1}},$2,1;
817 delete $variables->{param}{$1};
820 # we'll add extra comands here once I figure out what they
823 # add in a few utility routines
824 $variables->{output_select_options} = sub {
825 my ($options,$value) = @_;
826 my @options = @{$options};
828 while (my ($o_value,$name) = splice @options,0,2) {
830 if (defined $value and $o_value eq $value) {
831 $selected = ' selected';
833 $output .= qq(<option value="$o_value"$selected>$name</option>\n);
837 $variables->{make_list} = sub { make_list(@_);
839 # now at this point, we're ready to create the template
840 return Debbugs::Text::fill_in_template(template=>$param{template},
841 (exists $param{language}?(language=>$param{language}):()),
842 variables => $variables,
847 my ($param,$key,@values) = @_;
849 if (exists $param->{$key} and not
850 ref $param->{$key}) {
851 @{$param->{$key}} = [$param->{$key},
856 push @{$param->{$key}}, @values;
870 Decodes the funky maintainer encoding.
872 Don't ask me what in the world it does.
878 return () unless @input;
880 for my $input (@input) {
881 my $decoded = $input;
882 $decoded =~ s/-([^_]+)/-$1_-/g;
883 $decoded =~ s/_/-20_/g;
884 $decoded =~ s/^,(.*),(.*),([^,]+)$/$1-40_$2-20_-28_$3-29_/;
885 $decoded =~ s/^([^,]+),(.*),(.*),/$1-20_-3c_$2-40_$3-3e_/;
886 $decoded =~ s/\./-2e_/g;
887 $decoded =~ s/-([0-9a-f]{2})_/pack('H*',$1)/ge;
888 push @output,$decoded;
890 wantarray ? @output : $output[0];