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 Exporter qw(import);
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);
54 use Digest::MD5 qw(md5_hex);
57 use Debbugs::Text qw(fill_in_template);
63 ($VERSION) = q$Revision: 1.3 $ =~ /^Revision:\s+([^\s+])/;
64 $DEBUG = 0 unless defined $DEBUG;
67 %EXPORT_TAGS = (url => [qw(bug_url bug_links bug_linklist maybelink),
68 qw(set_url_params pkg_url version_url),
69 qw(submitterurl mainturl munge_url),
70 qw(package_links bug_links),
72 html => [qw(html_escape htmlize_bugs htmlize_packagelinks),
73 qw(maybelink htmlize_addresslinks htmlize_maintlinks),
75 util => [qw(cgi_parameters quitcgi),
77 forms => [qw(option_form form_options_and_normal_param)],
78 usertags => [qw(add_user)],
79 misc => [qw(maint_decode)],
80 package_search => [qw(@package_search_key_order %package_search_keys)],
81 cache => [qw(calculate_etag etag_does_not_match)],
82 #status => [qw(getbugstatus)],
85 Exporter::export_ok_tags(keys %EXPORT_TAGS);
86 $EXPORT_TAGS{all} = [@EXPORT_OK];
96 Sets the url params which will be used to generate urls.
105 my $url = Debbugs::URI->new($_[0]||'');
106 %URL_PARAMS = %{$url->query_form_hash};
113 bug_url($ref,mbox=>'yes',mboxstat=>'yes');
115 Constructs urls which point to a specific
117 XXX use Params::Validate
126 %params = (%URL_PARAMS,@_);
131 carp "bug_url is deprecated, use bug_links instead";
133 return munge_url('bugreport.cgi?',%params,bug=>$ref);
140 %params = (%URL_PARAMS,@_);
145 carp "pkg_url is deprecated, use package_links instead";
146 return munge_url('pkgreport.cgi?',%params);
151 my $url = munge_url($url,%params_to_munge);
153 Munges a url, replacing parameters with %params_to_munge as appropriate.
160 my $new_url = Debbugs::URI->new($url);
161 my @old_param = $new_url->query_form();
163 while (my ($key,$value) = splice @old_param,0,2) {
164 push @new_param,($key,$value) unless exists $params{$key};
166 $new_url->query_form(@new_param,
167 map {($_,$params{$_})}
169 return $new_url->as_string;
175 version_url(package => $package,found => $found,fixed => $fixed)
177 Creates a link to the version cgi script
181 =item package -- source package whose graph to display
183 =item found -- arrayref of found versions
185 =item fixed -- arrayref of fixed versions
187 =item width -- optional width of graph
189 =item height -- optional height of graph
191 =item info -- display html info surrounding graph; defaults to 1 if
192 width and height are not passed.
194 =item collapse -- whether to collapse the graph; defaults to 1 if
195 width and height are passed.
202 my %params = validate_with(params => \@_,
203 spec => {package => {type => SCALAR|ARRAYREF,
205 found => {type => ARRAYREF,
208 fixed => {type => ARRAYREF,
211 width => {type => SCALAR,
214 height => {type => SCALAR,
217 absolute => {type => BOOLEAN,
220 collapse => {type => BOOLEAN,
223 info => {type => BOOLEAN,
228 if (not defined $params{width} and not defined $params{height}) {
229 $params{info} = 1 if not exists $params{info};
231 my $url = Debbugs::URI->new('version.cgi?');
232 $url->query_form(%params);
233 return $url->as_string;
240 Escapes html entities by calling HTML::Entities::encode_entities;
247 return HTML::Entities::encode_entities($string,q(<>&"'));
250 =head2 cgi_parameters
254 Returns all of the cgi_parameters from a CGI script using CGI::Simple
259 my %options = validate_with(params => \@_,
260 spec => {query => {type => OBJECT,
263 single => {type => ARRAYREF,
266 default => {type => HASHREF,
271 my $q = $options{query};
273 @single{@{$options{single}}} = (1) x @{$options{single}};
275 for my $paramname ($q->param) {
276 if ($single{$paramname}) {
277 $param{$paramname} = $q->param($paramname);
280 $param{$paramname} = [$q->param($paramname)];
283 for my $default (keys %{$options{default}}) {
284 if (not exists $param{$default}) {
285 # We'll clone the reference here to avoid surprises later.
286 $param{$default} = ref($options{default}{$default})?
287 dclone($options{default}{$default}):$options{default}{$default};
296 print "Content-Type: text/html\n\n";
297 print fill_in_template(template=>'cgi/quit',
298 variables => {msg => $msg}
306 =head2 htmlize_packagelinks
310 Given a scalar containing a list of packages separated by something
311 that L<Debbugs::CGI/splitpackages> can separate, returns a
312 formatted set of links to packages in html.
316 sub htmlize_packagelinks {
318 return '' unless defined $pkgs and $pkgs ne '';
319 my @pkglist = splitpackages($pkgs);
321 carp "htmlize_packagelinks is deprecated, use package_links instead";
323 return 'Package' . (@pkglist > 1 ? 's' : '') . ': ' .
324 package_links(package =>\@pkglist,
331 join(', ', package_links(packages => \@packages))
333 Given a list of packages, return a list of html which links to the package
337 =item package -- arrayref or scalar of package(s)
339 =item submitter -- arrayref or scalar of submitter(s)
341 =item src -- arrayref or scalar of source(s)
343 =item maintainer -- arrayref or scalar of maintainer(s)
345 =item links_only -- return only links, not htmlized links, defaults to
346 returning htmlized links.
348 =item class -- class of the a href, defaults to ''
354 our @package_search_key_order = (package => 'in package',
356 severity => 'with severity',
357 src => 'in source package',
358 maint => 'in packages maintained by',
359 submitter => 'submitted by',
361 status => 'with status',
362 affects => 'which affect package',
363 correspondent => 'with mail from',
364 newest => 'newest bugs',
367 our %package_search_keys = @package_search_key_order;
371 my %param = validate_with(params => \@_,
372 spec => {(map { ($_,{type => SCALAR|ARRAYREF,
375 } keys %package_search_keys,
377 links_only => {type => BOOLEAN,
380 class => {type => SCALAR,
383 separator => {type => SCALAR,
386 options => {type => HASHREF,
393 my %map = (source => 'src',
394 maintainer => 'maint',
397 return $map{$key} if exists $map{$key};
401 my %options = %{$param{options}};
402 for ((keys %package_search_keys,qw(msg att))) {
403 delete $options{$_} if exists $options{$_};
406 for my $type (qw(src package)) {
407 push @links, map {my $t_type = $type;
408 if ($_ =~ s/^src://) {
411 (munge_url('pkgreport.cgi?',
415 ($t_type eq 'src'?'src:':'').$_);
416 } make_list($param{$type}) if exists $param{$type};
418 for my $type (qw(maint owner submitter correspondent)) {
419 push @links, map {my $addr = getparsedaddrs($_);
420 $addr = defined $addr?$addr->address:'';
421 (munge_url('pkgreport.cgi?',
426 } make_list($param{$type}) if exists $param{$type};
429 my ($link,$link_name);
431 if (length $param{class}) {
432 $class = q( class=").html_escape($param{class}).q(");
434 while (($link,$link_name) = splice(@links,0,2)) {
435 if ($param{links_only}) {
441 html_escape($link).q(">).
442 html_escape($link_name).q(</a>);
449 return join($param{separator},@return);
455 join(', ', bug_links(bug => \@packages))
457 Given a list of bugs, return a list of html which links to the bugs
461 =item bug -- arrayref or scalar of bug(s)
463 =item links_only -- return only links, not htmlized links, defaults to
464 returning htmlized links.
466 =item class -- class of the a href, defaults to ''
473 my %param = validate_with(params => \@_,
474 spec => {bug => {type => SCALAR|ARRAYREF,
477 links_only => {type => BOOLEAN,
480 class => {type => SCALAR,
483 separator => {type => SCALAR,
486 options => {type => HASHREF,
491 my %options = %{$param{options}};
494 delete $options{$_} if exists $options{$_};
497 push @links, map {(munge_url('bugreport.cgi?',
502 } make_list($param{bug}) if exists $param{bug};
504 my ($link,$link_name);
506 if (length $param{class}) {
507 $class = q( class=").html_escape($param{class}).q(");
509 while (($link,$link_name) = splice(@links,0,2)) {
510 if ($param{links_only}) {
516 html_escape($link).q(">).
517 html_escape($link_name).q(</a>);
524 return join($param{separator},@return);
533 maybelink('http://foobarbaz,http://bleh',qr/[, ]+/);
534 maybelink('http://foobarbaz,http://bleh',qr/[, ]+/,', ');
537 In the first form, links the link if it looks like a link. In the
538 second form, first splits based on the regex, then reassembles the
539 link, linking things that look like links. In the third form, rejoins
540 the split links with commas and spaces.
545 my ($links,$regex,$join) = @_;
546 if (not defined $regex and not defined $join) {
547 $links =~ s{(.*?)((?:(?:ftp|http|https)://[\S~-]+?/?)?)([\)\'\:\.\,]?(?:\s|\.<|$))}
548 {html_escape($1).(length $2?q(<a href=").html_escape($2).q(">).html_escape($2).q(</a>):'').html_escape($3)}geimo;
551 $join = ' ' if not defined $join;
554 if (defined $regex) {
555 @segments = split $regex, $links;
558 @segments = ($links);
560 for my $in (@segments) {
561 if ($in =~ /^[a-zA-Z0-9+.-]+:/) { # RFC 1738 scheme
562 push @return, qq{<a href="$in">} . html_escape($in) . '</a>';
564 push @return, html_escape($in);
567 return @return?join($join,@return):'';
571 =head2 htmlize_addresslinks
573 htmlize_addresslinks($prefixfunc,$urlfunc,$addresses,$class);
576 Generate a comma-separated list of HTML links to each address given in
577 $addresses, which should be a comma-separated list of RFC822
578 addresses. $urlfunc should be a reference to a function like mainturl
579 or submitterurl which returns the URL for each individual address.
584 sub htmlize_addresslinks {
585 my ($prefixfunc, $urlfunc, $addresses,$class) = @_;
586 carp "htmlize_addresslinks is deprecated";
588 $class = defined $class?qq(class="$class" ):'';
589 if (defined $addresses and $addresses ne '') {
590 my @addrs = getparsedaddrs($addresses);
591 my $prefix = (ref $prefixfunc) ?
592 $prefixfunc->(scalar @addrs):$prefixfunc;
595 { sprintf qq(<a ${class}).
597 $urlfunc->($_->address),
598 html_escape($_->format) ||
604 my $prefix = (ref $prefixfunc) ?
605 $prefixfunc->(1) : $prefixfunc;
606 return sprintf '%s<a '.$class.'href="%s">(unknown)</a>',
607 $prefix, $urlfunc->('');
612 my $addr = getparsedaddrs($_[0] || "");
613 $addr = defined $addr?$addr->address:'';
617 sub mainturl { package_links(maint => $_[0], links_only => 1); }
618 sub submitterurl { package_links(submitter => $_[0], links_only => 1); }
619 sub htmlize_maintlinks {
620 my ($prefixfunc, $maints) = @_;
621 carp "htmlize_maintlinks is deprecated";
622 return htmlize_addresslinks($prefixfunc, \&mainturl, $maints);
627 our $_maintainer_rev;
631 bug_linklist($separator,$class,@bugs)
633 Creates a set of links to C<@bugs> separated by C<$separator> with
634 link class C<$class>.
636 XXX Use L<Params::Validate>; we want to be able to support query
637 arguments here too; we should be able to combine bug_links and this
638 function into one. [Hell, bug_url should be one function with this one
645 my ($sep,$class,@bugs) = @_;
646 carp "bug_linklist is deprecated; use bug_links instead";
647 return scalar bug_links(bug=>\@bugs,class=>$class,separator=>$sep);
652 my ($user,$usertags,$bug_usertags,$seen_users,$cats,$hidden) = @_;
653 $seen_users = {} if not defined $seen_users;
654 $bug_usertags = {} if not defined $bug_usertags;
655 $usertags = {} if not defined $usertags;
656 $cats = {} if not defined $cats;
657 $hidden = {} if not defined $hidden;
658 return if exists $seen_users->{$user};
659 $seen_users->{$user} = 1;
661 my $u = Debbugs::User::get_user($user);
663 my %vis = map { $_, 1 } @{$u->{"visible_cats"}};
664 for my $c (keys %{$u->{"categories"}}) {
665 $cats->{$c} = $u->{"categories"}->{$c};
666 $hidden->{$c} = 1 unless defined $vis{$c};
668 for my $t (keys %{$u->{"tags"}}) {
669 $usertags->{$t} = [] unless defined $usertags->{$t};
670 push @{$usertags->{$t}}, @{$u->{"tags"}->{$t}};
673 %{$bug_usertags} = ();
674 for my $t (keys %{$usertags}) {
675 for my $b (@{$usertags->{$t}}) {
676 $bug_usertags->{$b} = [] unless defined $bug_usertags->{$b};
677 push @{$bug_usertags->{$b}}, $t;
688 =head2 form_options_and_normal_param
690 my ($form_option,$param) = form_options_and_normal_param(\%param)
691 if $param{form_options};
692 my $form_option = form_options_and_normal_param(\%param)
693 if $param{form_options};
695 Translates from special form_options to a set of parameters which can
696 be used to run the current page.
698 The idea behind this is to allow complex forms to relatively easily
699 cause options that the existing cgi scripts understand to be set.
701 Currently there are two commands which are understood:
702 combine, and concatenate.
706 Combine works by entering key,value pairs into the parameters using
707 the key field option input field, and the value field option input
710 For example, you would have
712 <input type="hidden" name="_fo_combine_key_fo_searchkey_value_fo_searchvalue" value="1">
714 which would combine the _fo_searchkey and _fo_searchvalue input fields, so
716 <input type="text" name="_fo_searchkey" value="foo">
717 <input type="text" name="_fo_searchvalue" value="bar">
719 would yield foo=>'bar' in %param.
723 Concatenate concatenates values into a single entry in a parameter
725 For example, you would have
727 <input type="hidden" name="_fo_concatentate_into_foo_with_:_fo_blah_fo_bleargh" value="1">
729 which would combine the _fo_searchkey and _fo_searchvalue input fields, so
731 <input type="text" name="_fo_blah" value="bar">
732 <input type="text" name="_fo_bleargh" value="baz">
734 would yield foo=>'bar:baz' in %param.
739 my $form_option_leader = '_fo_';
740 sub form_options_and_normal_param{
741 my ($orig_param) = @_;
742 # all form_option parameters start with _fo_
743 my ($param,$form_option) = ({},{});
744 for my $key (keys %{$orig_param}) {
745 if ($key =~ /^\Q$form_option_leader\E/) {
746 $form_option->{$key} = $orig_param->{$key};
749 $param->{$key} = $orig_param->{$key};
752 # at this point, we check for commands
753 COMMAND: for my $key (keys %{$form_option}) {
754 $key =~ s/^\Q$form_option_leader\E//;
755 if (my ($key_name,$value_name) =
756 $key =~ /combine_key(\Q$form_option_leader\E.+)
757 _value(\Q$form_option_leader\E.+)$/x
759 next unless defined $form_option->{$key_name};
760 next unless defined $form_option->{$value_name};
761 my @keys = make_list($form_option->{$key_name});
762 my @values = make_list($form_option->{$value_name});
763 for my $i (0 .. $#keys) {
764 last if $i > $#values;
765 next if not defined $keys[$i];
766 next if not defined $values[$i];
767 __add_to_param($param,
773 elsif (my ($field,$concatenate_key,$fields) =
774 $key =~ /concatenate_into_(.+?)((?:_with_[^_])?)
775 ((?:\Q$form_option_leader\E.+?)+)
778 if (length $concatenate_key) {
779 $concatenate_key =~ s/_with_//;
782 $concatenate_key = ':';
784 my @fields = $fields =~ m/(\Q$form_option_leader\E.+?)(?:(?=\Q$form_option_leader\E)|$)/g;
787 for my $f (@fields) {
788 next COMMAND unless defined $form_option->{$f};
789 $field_list{$f} = [make_list($form_option->{$f})];
790 $max_num = max($max_num,$#{$field_list{$f}});
792 for my $i (0 .. $max_num) {
793 next unless @fields == grep {$i <= $#{$field_list{$_}} and
794 defined $field_list{$_}[$i]} @fields;
795 __add_to_param($param,
797 join($concatenate_key,
798 map {$field_list{$_}[$i]} @fields
804 return wantarray?($form_option,$param):$form_option;
809 print option_form(template=>'pkgreport_options',
811 form_options => $form_options,
819 my %param = validate_with(params => \@_,
820 spec => {template => {type => SCALAR,
822 variables => {type => HASHREF,
825 language => {type => SCALAR,
828 param => {type => HASHREF,
831 form_options => {type => HASHREF,
837 # First, we need to see if we need to add particular types of
839 my $variables = dclone($param{variables});
840 $variables->{param} = dclone($param{param});
841 for my $key (keys %{$param{form_option}}) {
842 # strip out leader; shouldn't be anything here without one,
843 # but skip stupid things anyway
845 next unless $key =~ s/^\Q$form_option_leader\E//;
846 if ($key =~ /^add_(.+)$/) {
847 # this causes a specific parameter to be added
848 __add_to_param($variables->{param},
853 elsif ($key =~ /^delete_(.+?)(?:_(\d+))?$/) {
854 next unless exists $variables->{param}{$1};
855 if (ref $variables->{param}{$1} eq 'ARRAY' and
857 defined $variables->{param}{$1}[$2]
859 splice @{$variables->{param}{$1}},$2,1;
862 delete $variables->{param}{$1};
865 # we'll add extra comands here once I figure out what they
868 # add in a few utility routines
869 $variables->{output_select_options} = sub {
870 my ($options,$value) = @_;
871 my @options = @{$options};
873 while (my ($o_value,$name) = splice @options,0,2) {
875 if (defined $value and $o_value eq $value) {
876 $selected = ' selected';
878 $output .= q(<option value=").html_escape($o_value).qq("$selected>).
879 html_escape($name).qq(</option>\n);
883 $variables->{make_list} = sub { make_list(@_);
885 # now at this point, we're ready to create the template
886 return Debbugs::Text::fill_in_template(template=>$param{template},
887 (exists $param{language}?(language=>$param{language}):()),
888 variables => $variables,
889 hole_var => {'&html_escape' => \&html_escape,
895 my ($param,$key,@values) = @_;
897 if (exists $param->{$key} and not
898 ref $param->{$key}) {
899 @{$param->{$key}} = [$param->{$key},
904 push @{$param->{$key}}, @values;
918 Decodes the funky maintainer encoding.
920 Don't ask me what in the world it does.
926 return () unless @input;
928 for my $input (@input) {
929 my $decoded = $input;
930 $decoded =~ s/-([^_]+)/-$1_-/g;
931 $decoded =~ s/_/-20_/g;
932 $decoded =~ s/^,(.*),(.*),([^,]+)$/$1-40_$2-20_-28_$3-29_/;
933 $decoded =~ s/^([^,]+),(.*),(.*),/$1-20_-3c_$2-40_$3-3e_/;
934 $decoded =~ s/\./-2e_/g;
935 $decoded =~ s/-([0-9a-f]{2})_/pack('H*',$1)/ge;
936 push @output,$decoded;
938 wantarray ? @output : $output[0];
943 =head2 calculate_etags
945 calculate_etags(files => [qw(list of files)],additional_data => [qw(any additional data)]);
949 sub calculate_etags {
951 validate_with(params => \@_,
952 spec => {files => {type => ARRAYREF,
955 additional_data => {type => ARRAYREF,
960 my @additional_data = @{$param{additional_data}};
961 for my $file (@{$param{files}}) {
962 my $st = stat($file) or warn "Unable to stat $file: $!";
963 push @additional_data,$st->mtime;
964 push @additional_data,$st->size;
966 return(md5_hex(join('',sort @additional_data)));
969 =head2 etag_does_not_match
971 etag_does_not_match(cgi=>$q,files=>[qw(list of files)],
972 additional_data=>[qw(any additional data)])
975 Checks to see if the CGI request contains an etag which matches the calculated
978 If there wasn't an etag given, or the etag given doesn't match, return the etag.
980 If the etag does match, return 0.
984 sub etag_does_not_match {
986 validate_with(params => \@_,
987 spec => {files => {type => ARRAYREF,
990 additional_data => {type => ARRAYREF,
993 cgi => {type => OBJECT},
997 $param{cgi}->http('if-none-match');
999 calculate_etags(files=>$param{files},
1000 additional_data=>$param{additional_data});
1001 if (not defined $submitted_etag or
1002 length($submitted_etag) != 32
1003 or $etag ne $submitted_etag
1007 if ($etag eq $submitted_etag) {