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);
22 This module is a replacement for parts of common.pl; subroutines in
23 common.pl will be gradually phased out and replaced with equivalent
24 (or better) functionality here.
34 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
35 use Exporter qw(import);
40 ($VERSION) = q$Revision: 1.3 $ =~ /^Revision:\s+([^\s+])/;
41 $DEBUG = 0 unless defined $DEBUG;
44 %EXPORT_TAGS = (url => [qw(bug_links bug_linklist maybelink),
45 qw(set_url_params version_url),
46 qw(submitterurl mainturl munge_url),
47 qw(package_links bug_links),
49 html => [qw(html_escape htmlize_bugs htmlize_packagelinks),
50 qw(maybelink htmlize_addresslinks htmlize_maintlinks),
52 util => [qw(cgi_parameters quitcgi),
54 forms => [qw(option_form form_options_and_normal_param)],
55 usertags => [qw(add_user)],
56 misc => [qw(maint_decode)],
57 package_search => [qw(@package_search_key_order %package_search_keys)],
58 cache => [qw(calculate_etag etag_does_not_match)],
59 #status => [qw(getbugstatus)],
62 Exporter::export_ok_tags(keys %EXPORT_TAGS);
63 $EXPORT_TAGS{all} = [@EXPORT_OK];
68 use Debbugs::Common qw(getparsedaddrs make_list);
69 use Params::Validate qw(validate_with :types);
71 use Debbugs::Config qw(:config);
72 use Debbugs::Status qw(splitpackages isstrongseverity);
73 use Debbugs::User qw();
77 use Storable qw(dclone);
79 use List::AllUtils qw(max);
81 use Digest::MD5 qw(md5_hex);
84 use Debbugs::Text qw(fill_in_template);
93 Sets the url params which will be used to generate urls.
102 my $url = Debbugs::URI->new($_[0]||'');
103 %URL_PARAMS = %{$url->query_form_hash};
110 my $url = munge_url($url,%params_to_munge);
112 Munges a url, replacing parameters with %params_to_munge as appropriate.
119 my $new_url = Debbugs::URI->new($url);
120 my @old_param = $new_url->query_form();
122 while (my ($key,$value) = splice @old_param,0,2) {
123 push @new_param,($key,$value) unless exists $params{$key};
125 $new_url->query_form(@new_param,
126 map {($_,$params{$_})}
128 return $new_url->as_string;
134 version_url(package => $package,found => $found,fixed => $fixed)
136 Creates a link to the version cgi script
140 =item package -- source package whose graph to display
142 =item found -- arrayref of found versions
144 =item fixed -- arrayref of fixed versions
146 =item width -- optional width of graph
148 =item height -- optional height of graph
150 =item info -- display html info surrounding graph; defaults to 1 if
151 width and height are not passed.
153 =item collapse -- whether to collapse the graph; defaults to 1 if
154 width and height are passed.
161 my %params = validate_with(params => \@_,
162 spec => {package => {type => SCALAR|ARRAYREF,
164 found => {type => ARRAYREF,
167 fixed => {type => ARRAYREF,
170 width => {type => SCALAR,
173 height => {type => SCALAR,
176 absolute => {type => BOOLEAN,
179 collapse => {type => BOOLEAN,
182 info => {type => BOOLEAN,
187 if (not defined $params{width} and not defined $params{height}) {
188 $params{info} = 1 if not exists $params{info};
190 my $url = Debbugs::URI->new('version.cgi?');
191 $url->query_form(%params);
192 return $url->as_string;
199 Escapes html entities by calling HTML::Entities::encode_entities;
206 return HTML::Entities::encode_entities($string,q(<>&"'));
209 =head2 cgi_parameters
213 Returns all of the cgi_parameters from a CGI script using CGI::Simple
218 my %options = validate_with(params => \@_,
219 spec => {query => {type => OBJECT,
222 single => {type => ARRAYREF,
225 default => {type => HASHREF,
230 my $q = $options{query};
232 @single{@{$options{single}}} = (1) x @{$options{single}};
234 for my $paramname ($q->param) {
235 if ($single{$paramname}) {
236 $param{$paramname} = $q->param($paramname);
239 $param{$paramname} = [$q->param($paramname)];
242 for my $default (keys %{$options{default}}) {
243 if (not exists $param{$default}) {
244 # We'll clone the reference here to avoid surprises later.
245 $param{$default} = ref($options{default}{$default})?
246 dclone($options{default}{$default}):$options{default}{$default};
254 my ($msg, $status) = @_;
255 $status //= '500 Internal Server Error';
256 print "Status: $status\n";
257 print "Content-Type: text/html\n\n";
258 print fill_in_template(template=>'cgi/quit',
259 variables => {msg => $msg}
267 =head2 htmlize_packagelinks
271 Given a scalar containing a list of packages separated by something
272 that L<Debbugs::CGI/splitpackages> can separate, returns a
273 formatted set of links to packages in html.
277 sub htmlize_packagelinks {
279 return '' unless defined $pkgs and $pkgs ne '';
280 my @pkglist = splitpackages($pkgs);
282 carp "htmlize_packagelinks is deprecated, use package_links instead";
284 return 'Package' . (@pkglist > 1 ? 's' : '') . ': ' .
285 package_links(package =>\@pkglist,
292 join(', ', package_links(packages => \@packages))
294 Given a list of packages, return a list of html which links to the package
298 =item package -- arrayref or scalar of package(s)
300 =item submitter -- arrayref or scalar of submitter(s)
302 =item src -- arrayref or scalar of source(s)
304 =item maintainer -- arrayref or scalar of maintainer(s)
306 =item links_only -- return only links, not htmlized links, defaults to
307 returning htmlized links.
309 =item class -- class of the a href, defaults to ''
315 our @package_search_key_order = (package => 'in package',
317 severity => 'with severity',
318 src => 'in source package',
319 maint => 'in packages maintained by',
320 submitter => 'submitted by',
322 status => 'with status',
323 affects => 'which affect package',
324 correspondent => 'with mail from',
325 newest => 'newest bugs',
328 our %package_search_keys = @package_search_key_order;
332 my %param = validate_with(params => \@_,
333 spec => {(map { ($_,{type => SCALAR|ARRAYREF,
336 } keys %package_search_keys,
338 links_only => {type => BOOLEAN,
341 class => {type => SCALAR,
344 separator => {type => SCALAR,
347 options => {type => HASHREF,
354 my %map = (source => 'src',
355 maintainer => 'maint',
358 return $map{$key} if exists $map{$key};
362 my %options = %{$param{options}};
363 for ((keys %package_search_keys,qw(msg att))) {
364 delete $options{$_} if exists $options{$_};
367 for my $type (qw(src package)) {
368 push @links, map {my $t_type = $type;
369 if ($_ =~ s/^src://) {
372 (munge_url('pkgreport.cgi?',
376 ($t_type eq 'src'?'src:':'').$_);
377 } make_list($param{$type}) if exists $param{$type};
379 for my $type (qw(maint owner submitter correspondent)) {
380 push @links, map {my $addr = getparsedaddrs($_);
381 $addr = defined $addr?$addr->address:'';
382 (munge_url('pkgreport.cgi?',
387 } make_list($param{$type}) if exists $param{$type};
390 my ($link,$link_name);
392 if (length $param{class}) {
393 $class = q( class=").html_escape($param{class}).q(");
395 while (($link,$link_name) = splice(@links,0,2)) {
396 if ($param{links_only}) {
402 html_escape($link).q(">).
403 html_escape($link_name).q(</a>);
410 return join($param{separator},@return);
416 join(', ', bug_links(bug => \@packages))
418 Given a list of bugs, return a list of html which links to the bugs
422 =item bug -- arrayref or scalar of bug(s)
424 =item links_only -- return only links, not htmlized links, defaults to
425 returning htmlized links.
427 =item class -- class of the a href, defaults to ''
434 my %param = validate_with(params => \@_,
435 spec => {bug => {type => SCALAR|ARRAYREF,
438 links_only => {type => BOOLEAN,
441 class => {type => SCALAR,
444 separator => {type => SCALAR,
447 options => {type => HASHREF,
452 my %options = %{$param{options}};
455 delete $options{$_} if exists $options{$_};
458 push @links, map {(munge_url('bugreport.cgi?',
463 } make_list($param{bug}) if exists $param{bug};
465 my ($link,$link_name);
467 if (length $param{class}) {
468 $class = q( class=").html_escape($param{class}).q(");
470 while (($link,$link_name) = splice(@links,0,2)) {
471 if ($param{links_only}) {
477 html_escape($link).q(">).
478 html_escape($link_name).q(</a>);
485 return join($param{separator},@return);
494 maybelink('http://foobarbaz,http://bleh',qr/[, ]+/);
495 maybelink('http://foobarbaz,http://bleh',qr/[, ]+/,', ');
498 In the first form, links the link if it looks like a link. In the
499 second form, first splits based on the regex, then reassembles the
500 link, linking things that look like links. In the third form, rejoins
501 the split links with commas and spaces.
506 my ($links,$regex,$join) = @_;
507 if (not defined $regex and not defined $join) {
508 $links =~ s{(.*?)((?:(?:ftp|http|https)://[\S~-]+?/?)?)([\)\'\:\.\,]?(?:\s|\.<|$))}
509 {html_escape($1).(length $2?q(<a href=").html_escape($2).q(">).html_escape($2).q(</a>):'').html_escape($3)}geimo;
512 $join = ' ' if not defined $join;
515 if (defined $regex) {
516 @segments = split $regex, $links;
519 @segments = ($links);
521 for my $in (@segments) {
522 if ($in =~ /^[a-zA-Z0-9+.-]+:/) { # RFC 1738 scheme
523 push @return, qq{<a href="$in">} . html_escape($in) . '</a>';
525 push @return, html_escape($in);
528 return @return?join($join,@return):'';
532 =head2 htmlize_addresslinks
534 htmlize_addresslinks($prefixfunc,$urlfunc,$addresses,$class);
537 Generate a comma-separated list of HTML links to each address given in
538 $addresses, which should be a comma-separated list of RFC822
539 addresses. $urlfunc should be a reference to a function like mainturl
540 or submitterurl which returns the URL for each individual address.
545 sub htmlize_addresslinks {
546 my ($prefixfunc, $urlfunc, $addresses,$class) = @_;
547 carp "htmlize_addresslinks is deprecated";
549 $class = defined $class?qq(class="$class" ):'';
550 if (defined $addresses and $addresses ne '') {
551 my @addrs = getparsedaddrs($addresses);
552 my $prefix = (ref $prefixfunc) ?
553 $prefixfunc->(scalar @addrs):$prefixfunc;
556 { sprintf qq(<a ${class}).
558 $urlfunc->($_->address),
559 html_escape($_->format) ||
565 my $prefix = (ref $prefixfunc) ?
566 $prefixfunc->(1) : $prefixfunc;
567 return sprintf '%s<a '.$class.'href="%s">(unknown)</a>',
568 $prefix, $urlfunc->('');
573 my $addr = getparsedaddrs($_[0] || "");
574 $addr = defined $addr?$addr->address:'';
578 sub mainturl { package_links(maintainer => $_[0], links_only => 1); }
579 sub submitterurl { package_links(submitter => $_[0], links_only => 1); }
580 sub htmlize_maintlinks {
581 my ($prefixfunc, $maints) = @_;
582 carp "htmlize_maintlinks is deprecated";
583 return htmlize_addresslinks($prefixfunc, \&mainturl, $maints);
588 bug_linklist($separator,$class,@bugs)
590 Creates a set of links to C<@bugs> separated by C<$separator> with
591 link class C<$class>.
593 XXX Use L<Params::Validate>; we want to be able to support query
594 arguments here too; we should be able to combine bug_links and this
601 my ($sep,$class,@bugs) = @_;
602 carp "bug_linklist is deprecated; use bug_links instead";
603 return scalar bug_links(bug=>\@bugs,class=>$class,separator=>$sep);
608 my ($user,$usertags,$bug_usertags,$seen_users,$cats,$hidden) = @_;
609 $seen_users = {} if not defined $seen_users;
610 $bug_usertags = {} if not defined $bug_usertags;
611 $usertags = {} if not defined $usertags;
612 $cats = {} if not defined $cats;
613 $hidden = {} if not defined $hidden;
614 return if exists $seen_users->{$user};
615 $seen_users->{$user} = 1;
617 my $u = Debbugs::User::get_user($user);
619 my %vis = map { $_, 1 } @{$u->{"visible_cats"}};
620 for my $c (keys %{$u->{"categories"}}) {
621 $cats->{$c} = $u->{"categories"}->{$c};
622 $hidden->{$c} = 1 unless defined $vis{$c};
624 for my $t (keys %{$u->{"tags"}}) {
625 $usertags->{$t} = [] unless defined $usertags->{$t};
626 push @{$usertags->{$t}}, @{$u->{"tags"}->{$t}};
629 %{$bug_usertags} = ();
630 for my $t (keys %{$usertags}) {
631 for my $b (@{$usertags->{$t}}) {
632 $bug_usertags->{$b} = [] unless defined $bug_usertags->{$b};
633 push @{$bug_usertags->{$b}}, $t;
644 =head2 form_options_and_normal_param
646 my ($form_option,$param) = form_options_and_normal_param(\%param)
647 if $param{form_options};
648 my $form_option = form_options_and_normal_param(\%param)
649 if $param{form_options};
651 Translates from special form_options to a set of parameters which can
652 be used to run the current page.
654 The idea behind this is to allow complex forms to relatively easily
655 cause options that the existing cgi scripts understand to be set.
657 Currently there are two commands which are understood:
658 combine, and concatenate.
662 Combine works by entering key,value pairs into the parameters using
663 the key field option input field, and the value field option input
666 For example, you would have
668 <input type="hidden" name="_fo_combine_key_fo_searchkey_value_fo_searchvalue" value="1">
670 which would combine the _fo_searchkey and _fo_searchvalue input fields, so
672 <input type="text" name="_fo_searchkey" value="foo">
673 <input type="text" name="_fo_searchvalue" value="bar">
675 would yield foo=>'bar' in %param.
679 Concatenate concatenates values into a single entry in a parameter
681 For example, you would have
683 <input type="hidden" name="_fo_concatentate_into_foo_with_:_fo_blah_fo_bleargh" value="1">
685 which would combine the _fo_searchkey and _fo_searchvalue input fields, so
687 <input type="text" name="_fo_blah" value="bar">
688 <input type="text" name="_fo_bleargh" value="baz">
690 would yield foo=>'bar:baz' in %param.
695 my $form_option_leader = '_fo_';
696 sub form_options_and_normal_param{
697 my ($orig_param) = @_;
698 # all form_option parameters start with _fo_
699 my ($param,$form_option) = ({},{});
700 for my $key (keys %{$orig_param}) {
701 if ($key =~ /^\Q$form_option_leader\E/) {
702 $form_option->{$key} = $orig_param->{$key};
705 $param->{$key} = $orig_param->{$key};
708 # at this point, we check for commands
709 COMMAND: for my $key (keys %{$form_option}) {
710 $key =~ s/^\Q$form_option_leader\E//;
711 if (my ($key_name,$value_name) =
712 $key =~ /combine_key(\Q$form_option_leader\E.+)
713 _value(\Q$form_option_leader\E.+)$/x
715 next unless defined $form_option->{$key_name};
716 next unless defined $form_option->{$value_name};
717 my @keys = make_list($form_option->{$key_name});
718 my @values = make_list($form_option->{$value_name});
719 for my $i (0 .. $#keys) {
720 last if $i > $#values;
721 next if not defined $keys[$i];
722 next if not defined $values[$i];
723 __add_to_param($param,
729 elsif (my ($field,$concatenate_key,$fields) =
730 $key =~ /concatenate_into_(.+?)((?:_with_[^_])?)
731 ((?:\Q$form_option_leader\E.+?)+)
734 if (length $concatenate_key) {
735 $concatenate_key =~ s/_with_//;
738 $concatenate_key = ':';
740 my @fields = $fields =~ m/(\Q$form_option_leader\E.+?)(?:(?=\Q$form_option_leader\E)|$)/g;
743 for my $f (@fields) {
744 next COMMAND unless defined $form_option->{$f};
745 $field_list{$f} = [make_list($form_option->{$f})];
746 $max_num = max($max_num,$#{$field_list{$f}});
748 for my $i (0 .. $max_num) {
749 next unless @fields == grep {$i <= $#{$field_list{$_}} and
750 defined $field_list{$_}[$i]} @fields;
751 __add_to_param($param,
753 join($concatenate_key,
754 map {$field_list{$_}[$i]} @fields
760 return wantarray?($form_option,$param):$form_option;
765 print option_form(template=>'pkgreport_options',
767 form_options => $form_options,
775 my %param = validate_with(params => \@_,
776 spec => {template => {type => SCALAR,
778 variables => {type => HASHREF,
781 language => {type => SCALAR,
784 param => {type => HASHREF,
787 form_options => {type => HASHREF,
793 # First, we need to see if we need to add particular types of
795 my $variables = dclone($param{variables});
796 $variables->{param} = dclone($param{param});
797 for my $key (keys %{$param{form_option}}) {
798 # strip out leader; shouldn't be anything here without one,
799 # 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 .= q(<option value=").html_escape($o_value).qq("$selected>).
834 html_escape($name).qq(</option>\n);
838 $variables->{make_list} = sub { make_list(@_);
840 # now at this point, we're ready to create the template
841 return Debbugs::Text::fill_in_template(template=>$param{template},
842 (exists $param{language}?(language=>$param{language}):()),
843 variables => $variables,
844 hole_var => {'&html_escape' => \&html_escape,
850 my ($param,$key,@values) = @_;
852 if (exists $param->{$key} and not
853 ref $param->{$key}) {
854 @{$param->{$key}} = [$param->{$key},
859 push @{$param->{$key}}, @values;
873 Decodes the funky maintainer encoding.
875 Don't ask me what in the world it does.
881 return () unless @input;
883 for my $input (@input) {
884 my $decoded = $input;
885 $decoded =~ s/-([^_]+)/-$1_-/g;
886 $decoded =~ s/_/-20_/g;
887 $decoded =~ s/^,(.*),(.*),([^,]+)$/$1-40_$2-20_-28_$3-29_/;
888 $decoded =~ s/^([^,]+),(.*),(.*),/$1-20_-3c_$2-40_$3-3e_/;
889 $decoded =~ s/\./-2e_/g;
890 $decoded =~ s/-([0-9a-f]{2})_/pack('H*',$1)/ge;
891 push @output,$decoded;
893 wantarray ? @output : $output[0];
898 =head2 calculate_etags
900 calculate_etags(files => [qw(list of files)],additional_data => [qw(any additional data)]);
904 sub calculate_etags {
906 validate_with(params => \@_,
907 spec => {files => {type => ARRAYREF,
910 additional_data => {type => ARRAYREF,
915 my @additional_data = @{$param{additional_data}};
916 for my $file (@{$param{files}}) {
917 my $st = stat($file) or warn "Unable to stat $file: $!";
918 push @additional_data,$st->mtime;
919 push @additional_data,$st->size;
921 return(md5_hex(join('',sort @additional_data)));
924 =head2 etag_does_not_match
926 etag_does_not_match(cgi=>$q,files=>[qw(list of files)],
927 additional_data=>[qw(any additional data)])
930 Checks to see if the CGI request contains an etag which matches the calculated
933 If there wasn't an etag given, or the etag given doesn't match, return the etag.
935 If the etag does match, return 0.
939 sub etag_does_not_match {
941 validate_with(params => \@_,
942 spec => {files => {type => ARRAYREF,
945 additional_data => {type => ARRAYREF,
948 cgi => {type => OBJECT},
952 $param{cgi}->http('if-none-match');
954 calculate_etags(files=>$param{files},
955 additional_data=>$param{additional_data});
956 if (not defined $submitted_etag or
957 length($submitted_etag) != 32
958 or $etag ne $submitted_etag
962 if ($etag eq $submitted_etag) {