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);
37 use feature qw(state);
42 ($VERSION) = q$Revision: 1.3 $ =~ /^Revision:\s+([^\s+])/;
43 $DEBUG = 0 unless defined $DEBUG;
46 %EXPORT_TAGS = (url => [qw(bug_links bug_linklist maybelink),
47 qw(set_url_params version_url),
48 qw(submitterurl mainturl munge_url),
49 qw(package_links bug_links),
51 html => [qw(html_escape htmlize_bugs htmlize_packagelinks),
52 qw(maybelink htmlize_addresslinks htmlize_maintlinks),
54 util => [qw(cgi_parameters quitcgi),
56 forms => [qw(option_form form_options_and_normal_param)],
57 usertags => [qw(add_user)],
58 misc => [qw(maint_decode)],
59 package_search => [qw(@package_search_key_order %package_search_keys)],
60 cache => [qw(calculate_etag etag_does_not_match)],
61 #status => [qw(getbugstatus)],
64 Exporter::export_ok_tags(keys %EXPORT_TAGS);
65 $EXPORT_TAGS{all} = [@EXPORT_OK];
71 use Debbugs::Common qw(getparsedaddrs make_list);
72 use Params::Validate qw(validate_with :types);
74 use Debbugs::Config qw(:config);
75 use Debbugs::Status qw(splitpackages isstrongseverity);
76 use Debbugs::User qw();
80 use Storable qw(dclone);
81 use Scalar::Util qw(looks_like_number);
83 use List::AllUtils qw(max);
85 use Digest::MD5 qw(md5_hex);
88 use Debbugs::Text qw(fill_in_template);
97 Sets the url params which will be used to generate urls.
106 my $url = Debbugs::URI->new($_[0]||'');
107 %URL_PARAMS = %{$url->query_form_hash};
114 my $url = munge_url($url,%params_to_munge);
116 Munges a url, replacing parameters with %params_to_munge as appropriate.
123 my $new_url = Debbugs::URI->new($url);
124 my @old_param = $new_url->query_form();
126 while (my ($key,$value) = splice @old_param,0,2) {
127 push @new_param,($key,$value) unless exists $params{$key};
129 $new_url->query_form(@new_param,
130 map {($_,$params{$_})}
132 return $new_url->as_string;
138 version_url(package => $package,found => $found,fixed => $fixed)
140 Creates a link to the version cgi script
144 =item package -- source package whose graph to display
146 =item found -- arrayref of found versions
148 =item fixed -- arrayref of fixed versions
150 =item format -- optional image format override
152 =item width -- optional width of graph
154 =item height -- optional height of graph
156 =item info -- display html info surrounding graph; defaults to 1 if
157 width and height are not passed.
159 =item collapse -- whether to collapse the graph; defaults to 1 if
160 width and height are passed.
167 my %params = validate_with(params => \@_,
168 spec => {package => {type => SCALAR|ARRAYREF,
170 found => {type => ARRAYREF,
173 fixed => {type => ARRAYREF,
176 format => {type => SCALAR,
179 width => {type => SCALAR,
182 height => {type => SCALAR,
185 absolute => {type => BOOLEAN,
188 collapse => {type => BOOLEAN,
191 info => {type => BOOLEAN,
196 if (not defined $params{width} and not defined $params{height}) {
197 $params{info} = 1 if not exists $params{info};
199 my $url = Debbugs::URI->new('version.cgi?');
200 $url->query_form(%params);
201 return $url->as_string;
208 Escapes html entities by calling HTML::Entities::encode_entities;
215 return HTML::Entities::encode_entities($string,q(<>&"'));
218 =head2 cgi_parameters
222 Returns all of the cgi_parameters from a CGI script using CGI::Simple
227 my %options = validate_with(params => \@_,
228 spec => {query => {type => OBJECT,
231 single => {type => ARRAYREF,
234 default => {type => HASHREF,
239 my $q = $options{query};
241 @single{@{$options{single}}} = (1) x @{$options{single}};
243 for my $paramname ($q->param) {
244 if ($single{$paramname}) {
245 $param{$paramname} = $q->param($paramname);
248 $param{$paramname} = [$q->param($paramname)];
251 for my $default (keys %{$options{default}}) {
252 if (not exists $param{$default}) {
253 # We'll clone the reference here to avoid surprises later.
254 $param{$default} = ref($options{default}{$default})?
255 dclone($options{default}{$default}):$options{default}{$default};
263 my ($msg, $status) = @_;
264 $status //= '500 Internal Server Error';
265 print "Status: $status\n";
266 print "Content-Type: text/html\n\n";
267 print fill_in_template(template=>'cgi/quit',
268 variables => {msg => $msg}
276 =head2 htmlize_packagelinks
280 Given a scalar containing a list of packages separated by something
281 that L<Debbugs::CGI/splitpackages> can separate, returns a
282 formatted set of links to packages in html.
286 sub htmlize_packagelinks {
288 return '' unless defined $pkgs and $pkgs ne '';
289 my @pkglist = splitpackages($pkgs);
291 carp "htmlize_packagelinks is deprecated, use package_links instead";
293 return 'Package' . (@pkglist > 1 ? 's' : '') . ': ' .
294 package_links(package =>\@pkglist,
301 join(', ', package_links(packages => \@packages))
303 Given a list of packages, return a list of html which links to the package
307 =item package -- arrayref or scalar of package(s)
309 =item submitter -- arrayref or scalar of submitter(s)
311 =item src -- arrayref or scalar of source(s)
313 =item maintainer -- arrayref or scalar of maintainer(s)
315 =item links_only -- return only links, not htmlized links, defaults to
316 returning htmlized links.
318 =item class -- class of the a href, defaults to ''
324 our @package_search_key_order = (package => 'in package',
326 severity => 'with severity',
327 src => 'in source package',
328 maint => 'in packages maintained by',
329 submitter => 'submitted by',
331 status => 'with status',
332 affects => 'which affect package',
333 correspondent => 'with mail from',
334 newest => 'newest bugs',
337 our %package_search_keys = @package_search_key_order;
338 our %package_links_invalid_options =
339 map {($_,1)} (keys %package_search_keys,
344 {(map { ($_,{type => SCALAR|ARRAYREF,
347 } keys %package_search_keys,
348 ## these are aliases for package
350 source => {type => SCALAR|ARRAYREF,
353 maintainer => {type => SCALAR|ARRAYREF,
357 links_only => {type => BOOLEAN,
360 class => {type => SCALAR,
363 separator => {type => SCALAR,
366 options => {type => HASHREF,
370 my %param = validate_with(params => \@_,
373 my %options = %{$param{options}};
374 for (grep {$package_links_invalid_options{$_}} keys %options) {
377 ## remove aliases for source and maintainer
378 if (exists $param{source}) {
379 $param{src} = [exists $param{src}?make_list($param{src}):(),
380 make_list($param{source}),
382 delete $param{source};
384 if (exists $param{maintainer}) {
385 $param{maint} = [exists $param{maint}?make_list($param{maint}):(),
386 make_list($param{maintainer}),
388 delete $param{maintainer};
390 my $has_options = keys %options;
392 for my $type (qw(src package)) {
393 next unless exists $param{$type};
394 for my $target (make_list($param{$type})) {
396 if ($target =~ s/^src://) {
398 } elsif ($t_type eq 'source') {
399 $target = 'src:'.$target;
403 (munge_url('pkgreport.cgi?',
410 ('pkgreport.cgi?'.$t_type.'='.uri_escape_utf8($target),
415 for my $type (qw(maint owner submitter correspondent)) {
416 next unless exists $param{$type};
417 for my $target (make_list($param{$type})) {
420 (munge_url('pkgreport.cgi?',
427 $type.'='.uri_escape_utf8($target),
433 my ($link,$link_name);
435 if (length $param{class}) {
436 $class = q( class=").html_escape($param{class}).q(");
438 while (($link,$link_name) = splice(@links,0,2)) {
439 if ($param{links_only}) {
445 html_escape($link).q(">).
446 html_escape($link_name).q(</a>);
453 return join($param{separator},@return);
459 join(', ', bug_links(bug => \@packages))
461 Given a list of bugs, return a list of html which links to the bugs
465 =item bug -- arrayref or scalar of bug(s)
467 =item links_only -- return only links, not htmlized links, defaults to
468 returning htmlized links.
470 =item class -- class of the a href, defaults to ''
477 state $spec = {bug => {type => SCALAR|ARRAYREF,
480 links_only => {type => BOOLEAN,
483 class => {type => SCALAR,
486 separator => {type => SCALAR,
489 options => {type => HASHREF,
493 my %param = validate_with(params => \@_,
496 my %options = %{$param{options}};
499 delete $options{$_} if exists $options{$_};
501 my $has_options = keys %options;
504 push @links, map {(munge_url('bugreport.cgi?',
509 } make_list($param{bug}) if exists $param{bug};
512 map {my $b = ceil($_);
513 ('bugreport.cgi?bug='.$b,
515 grep {looks_like_number($_)}
516 make_list($param{bug}) if exists $param{bug};
519 my ($link,$link_name);
521 if (length $param{class}) {
522 $class = q( class=").html_escape($param{class}).q(");
524 while (($link,$link_name) = splice(@links,0,2)) {
525 if ($param{links_only}) {
531 html_escape($link).q(">).
532 html_escape($link_name).q(</a>);
539 return join($param{separator},@return);
548 maybelink('http://foobarbaz,http://bleh',qr/[, ]+/);
549 maybelink('http://foobarbaz,http://bleh',qr/[, ]+/,', ');
552 In the first form, links the link if it looks like a link. In the
553 second form, first splits based on the regex, then reassembles the
554 link, linking things that look like links. In the third form, rejoins
555 the split links with commas and spaces.
560 my ($links,$regex,$join) = @_;
561 if (not defined $regex and not defined $join) {
562 $links =~ s{(.*?)((?:(?:ftp|http|https)://[\S~-]+?/?)?)([\)\'\:\.\,]?(?:\s|\.<|$))}
563 {html_escape($1).(length $2?q(<a href=").html_escape($2).q(">).html_escape($2).q(</a>):'').html_escape($3)}geimo;
566 $join = ' ' if not defined $join;
569 if (defined $regex) {
570 @segments = split $regex, $links;
573 @segments = ($links);
575 for my $in (@segments) {
576 if ($in =~ /^[a-zA-Z0-9+.-]+:/) { # RFC 1738 scheme
577 push @return, qq{<a href="$in">} . html_escape($in) . '</a>';
579 push @return, html_escape($in);
582 return @return?join($join,@return):'';
586 =head2 htmlize_addresslinks
588 htmlize_addresslinks($prefixfunc,$urlfunc,$addresses,$class);
591 Generate a comma-separated list of HTML links to each address given in
592 $addresses, which should be a comma-separated list of RFC822
593 addresses. $urlfunc should be a reference to a function like mainturl
594 or submitterurl which returns the URL for each individual address.
599 sub htmlize_addresslinks {
600 my ($prefixfunc, $urlfunc, $addresses,$class) = @_;
601 carp "htmlize_addresslinks is deprecated";
603 $class = defined $class?qq(class="$class" ):'';
604 if (defined $addresses and $addresses ne '') {
605 my @addrs = getparsedaddrs($addresses);
606 my $prefix = (ref $prefixfunc) ?
607 $prefixfunc->(scalar @addrs):$prefixfunc;
610 { sprintf qq(<a ${class}).
612 $urlfunc->($_->address),
613 html_escape($_->format) ||
619 my $prefix = (ref $prefixfunc) ?
620 $prefixfunc->(1) : $prefixfunc;
621 return sprintf '%s<a '.$class.'href="%s">(unknown)</a>',
622 $prefix, $urlfunc->('');
627 my $addr = getparsedaddrs($_[0] || "");
628 $addr = defined $addr?$addr->address:'';
632 sub mainturl { package_links(maintainer => $_[0], links_only => 1); }
633 sub submitterurl { package_links(submitter => $_[0], links_only => 1); }
634 sub htmlize_maintlinks {
635 my ($prefixfunc, $maints) = @_;
636 carp "htmlize_maintlinks is deprecated";
637 return htmlize_addresslinks($prefixfunc, \&mainturl, $maints);
642 bug_linklist($separator,$class,@bugs)
644 Creates a set of links to C<@bugs> separated by C<$separator> with
645 link class C<$class>.
647 XXX Use L<Params::Validate>; we want to be able to support query
648 arguments here too; we should be able to combine bug_links and this
655 my ($sep,$class,@bugs) = @_;
656 carp "bug_linklist is deprecated; use bug_links instead";
657 return scalar bug_links(bug=>\@bugs,class=>$class,separator=>$sep);
662 my ($user,$usertags,$bug_usertags,$seen_users,$cats,$hidden) = @_;
663 $seen_users = {} if not defined $seen_users;
664 $bug_usertags = {} if not defined $bug_usertags;
665 $usertags = {} if not defined $usertags;
666 $cats = {} if not defined $cats;
667 $hidden = {} if not defined $hidden;
668 return if exists $seen_users->{$user};
669 $seen_users->{$user} = 1;
671 my $u = Debbugs::User::get_user($user);
673 my %vis = map { $_, 1 } @{$u->{"visible_cats"}};
674 for my $c (keys %{$u->{"categories"}}) {
675 $cats->{$c} = $u->{"categories"}->{$c};
676 $hidden->{$c} = 1 unless defined $vis{$c};
678 for my $t (keys %{$u->{"tags"}}) {
679 $usertags->{$t} = [] unless defined $usertags->{$t};
680 push @{$usertags->{$t}}, @{$u->{"tags"}->{$t}};
683 %{$bug_usertags} = ();
684 for my $t (keys %{$usertags}) {
685 for my $b (@{$usertags->{$t}}) {
686 $bug_usertags->{$b} = [] unless defined $bug_usertags->{$b};
687 push @{$bug_usertags->{$b}}, $t;
698 =head2 form_options_and_normal_param
700 my ($form_option,$param) = form_options_and_normal_param(\%param)
701 if $param{form_options};
702 my $form_option = form_options_and_normal_param(\%param)
703 if $param{form_options};
705 Translates from special form_options to a set of parameters which can
706 be used to run the current page.
708 The idea behind this is to allow complex forms to relatively easily
709 cause options that the existing cgi scripts understand to be set.
711 Currently there are two commands which are understood:
712 combine, and concatenate.
716 Combine works by entering key,value pairs into the parameters using
717 the key field option input field, and the value field option input
720 For example, you would have
722 <input type="hidden" name="_fo_combine_key_fo_searchkey_value_fo_searchvalue" value="1">
724 which would combine the _fo_searchkey and _fo_searchvalue input fields, so
726 <input type="text" name="_fo_searchkey" value="foo">
727 <input type="text" name="_fo_searchvalue" value="bar">
729 would yield foo=>'bar' in %param.
733 Concatenate concatenates values into a single entry in a parameter
735 For example, you would have
737 <input type="hidden" name="_fo_concatentate_into_foo_with_:_fo_blah_fo_bleargh" value="1">
739 which would combine the _fo_searchkey and _fo_searchvalue input fields, so
741 <input type="text" name="_fo_blah" value="bar">
742 <input type="text" name="_fo_bleargh" value="baz">
744 would yield foo=>'bar:baz' in %param.
749 my $form_option_leader = '_fo_';
750 sub form_options_and_normal_param{
751 my ($orig_param) = @_;
752 # all form_option parameters start with _fo_
753 my ($param,$form_option) = ({},{});
754 for my $key (keys %{$orig_param}) {
755 if ($key =~ /^\Q$form_option_leader\E/) {
756 $form_option->{$key} = $orig_param->{$key};
759 $param->{$key} = $orig_param->{$key};
762 # at this point, we check for commands
763 COMMAND: for my $key (keys %{$form_option}) {
764 $key =~ s/^\Q$form_option_leader\E//;
765 if (my ($key_name,$value_name) =
766 $key =~ /combine_key(\Q$form_option_leader\E.+)
767 _value(\Q$form_option_leader\E.+)$/x
769 next unless defined $form_option->{$key_name};
770 next unless defined $form_option->{$value_name};
771 my @keys = make_list($form_option->{$key_name});
772 my @values = make_list($form_option->{$value_name});
773 for my $i (0 .. $#keys) {
774 last if $i > $#values;
775 next if not defined $keys[$i];
776 next if not defined $values[$i];
777 __add_to_param($param,
783 elsif (my ($field,$concatenate_key,$fields) =
784 $key =~ /concatenate_into_(.+?)((?:_with_[^_])?)
785 ((?:\Q$form_option_leader\E.+?)+)
788 if (length $concatenate_key) {
789 $concatenate_key =~ s/_with_//;
792 $concatenate_key = ':';
794 my @fields = $fields =~ m/(\Q$form_option_leader\E.+?)(?:(?=\Q$form_option_leader\E)|$)/g;
797 for my $f (@fields) {
798 next COMMAND unless defined $form_option->{$f};
799 $field_list{$f} = [make_list($form_option->{$f})];
800 $max_num = max($max_num,$#{$field_list{$f}});
802 for my $i (0 .. $max_num) {
803 next unless @fields == grep {$i <= $#{$field_list{$_}} and
804 defined $field_list{$_}[$i]} @fields;
805 __add_to_param($param,
807 join($concatenate_key,
808 map {$field_list{$_}[$i]} @fields
814 return wantarray?($form_option,$param):$form_option;
819 print option_form(template=>'pkgreport_options',
821 form_options => $form_options,
829 my %param = validate_with(params => \@_,
830 spec => {template => {type => SCALAR,
832 variables => {type => HASHREF,
835 language => {type => SCALAR,
838 param => {type => HASHREF,
841 form_options => {type => HASHREF,
847 # First, we need to see if we need to add particular types of
849 my $variables = dclone($param{variables});
850 $variables->{param} = dclone($param{param});
851 for my $key (keys %{$param{form_option}}) {
852 # strip out leader; shouldn't be anything here without one,
853 # but skip stupid things anyway
854 next unless $key =~ s/^\Q$form_option_leader\E//;
855 if ($key =~ /^add_(.+)$/) {
856 # this causes a specific parameter to be added
857 __add_to_param($variables->{param},
862 elsif ($key =~ /^delete_(.+?)(?:_(\d+))?$/) {
863 next unless exists $variables->{param}{$1};
864 if (ref $variables->{param}{$1} eq 'ARRAY' and
866 defined $variables->{param}{$1}[$2]
868 splice @{$variables->{param}{$1}},$2,1;
871 delete $variables->{param}{$1};
874 # we'll add extra comands here once I figure out what they
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];
935 =head2 calculate_etags
937 calculate_etags(files => [qw(list of files)],additional_data => [qw(any additional data)]);
941 sub calculate_etags {
943 validate_with(params => \@_,
944 spec => {files => {type => ARRAYREF,
947 additional_data => {type => ARRAYREF,
952 my @additional_data = @{$param{additional_data}};
953 for my $file (@{$param{files}}) {
954 my $st = stat($file) or warn "Unable to stat $file: $!";
955 push @additional_data,$st->mtime;
956 push @additional_data,$st->size;
958 return(md5_hex(join('',sort @additional_data)));
961 =head2 etag_does_not_match
963 etag_does_not_match(cgi=>$q,files=>[qw(list of files)],
964 additional_data=>[qw(any additional data)])
967 Checks to see if the CGI request contains an etag which matches the calculated
970 If there wasn't an etag given, or the etag given doesn't match, return the etag.
972 If the etag does match, return 0.
976 sub etag_does_not_match {
978 validate_with(params => \@_,
979 spec => {files => {type => ARRAYREF,
982 additional_data => {type => ARRAYREF,
985 cgi => {type => OBJECT},
989 $param{cgi}->http('if-none-match');
991 calculate_etags(files=>$param{files},
992 additional_data=>$param{additional_data});
993 if (not defined $submitted_etag or
994 length($submitted_etag) != 32
995 or $etag ne $submitted_etag
999 if ($etag eq $submitted_etag) {