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 width -- optional width of graph
152 =item height -- optional height of graph
154 =item info -- display html info surrounding graph; defaults to 1 if
155 width and height are not passed.
157 =item collapse -- whether to collapse the graph; defaults to 1 if
158 width and height are passed.
165 my %params = validate_with(params => \@_,
166 spec => {package => {type => SCALAR|ARRAYREF,
168 found => {type => ARRAYREF,
171 fixed => {type => ARRAYREF,
174 width => {type => SCALAR,
177 height => {type => SCALAR,
180 absolute => {type => BOOLEAN,
183 collapse => {type => BOOLEAN,
186 info => {type => BOOLEAN,
191 if (not defined $params{width} and not defined $params{height}) {
192 $params{info} = 1 if not exists $params{info};
194 my $url = Debbugs::URI->new('version.cgi?');
195 $url->query_form(%params);
196 return $url->as_string;
203 Escapes html entities by calling HTML::Entities::encode_entities;
210 return HTML::Entities::encode_entities($string,q(<>&"'));
213 =head2 cgi_parameters
217 Returns all of the cgi_parameters from a CGI script using CGI::Simple
222 my %options = validate_with(params => \@_,
223 spec => {query => {type => OBJECT,
226 single => {type => ARRAYREF,
229 default => {type => HASHREF,
234 my $q = $options{query};
236 @single{@{$options{single}}} = (1) x @{$options{single}};
238 for my $paramname ($q->param) {
239 if ($single{$paramname}) {
240 $param{$paramname} = $q->param($paramname);
243 $param{$paramname} = [$q->param($paramname)];
246 for my $default (keys %{$options{default}}) {
247 if (not exists $param{$default}) {
248 # We'll clone the reference here to avoid surprises later.
249 $param{$default} = ref($options{default}{$default})?
250 dclone($options{default}{$default}):$options{default}{$default};
258 my ($msg, $status) = @_;
259 $status //= '500 Internal Server Error';
260 print "Status: $status\n";
261 print "Content-Type: text/html\n\n";
262 print fill_in_template(template=>'cgi/quit',
263 variables => {msg => $msg}
271 =head2 htmlize_packagelinks
275 Given a scalar containing a list of packages separated by something
276 that L<Debbugs::CGI/splitpackages> can separate, returns a
277 formatted set of links to packages in html.
281 sub htmlize_packagelinks {
283 return '' unless defined $pkgs and $pkgs ne '';
284 my @pkglist = splitpackages($pkgs);
286 carp "htmlize_packagelinks is deprecated, use package_links instead";
288 return 'Package' . (@pkglist > 1 ? 's' : '') . ': ' .
289 package_links(package =>\@pkglist,
296 join(', ', package_links(packages => \@packages))
298 Given a list of packages, return a list of html which links to the package
302 =item package -- arrayref or scalar of package(s)
304 =item submitter -- arrayref or scalar of submitter(s)
306 =item src -- arrayref or scalar of source(s)
308 =item maintainer -- arrayref or scalar of maintainer(s)
310 =item links_only -- return only links, not htmlized links, defaults to
311 returning htmlized links.
313 =item class -- class of the a href, defaults to ''
319 our @package_search_key_order = (package => 'in package',
321 severity => 'with severity',
322 src => 'in source package',
323 maint => 'in packages maintained by',
324 submitter => 'submitted by',
326 status => 'with status',
327 affects => 'which affect package',
328 correspondent => 'with mail from',
329 newest => 'newest bugs',
332 our %package_search_keys = @package_search_key_order;
333 our %package_links_invalid_options =
334 map {($_,1)} (keys %package_search_keys,
339 {(map { ($_,{type => SCALAR|ARRAYREF,
342 } keys %package_search_keys,
343 ## these are aliases for package
345 source => {type => SCALAR|ARRAYREF,
348 maintainer => {type => SCALAR|ARRAYREF,
352 links_only => {type => BOOLEAN,
355 class => {type => SCALAR,
358 separator => {type => SCALAR,
361 options => {type => HASHREF,
365 my %param = validate_with(params => \@_,
368 my %options = %{$param{options}};
369 for (grep {$package_links_invalid_options{$_}} keys %options) {
372 ## remove aliases for source and maintainer
373 if (exists $param{source}) {
374 $param{src} = [exists $param{src}?make_list($param{src}):(),
375 make_list($param{source}),
377 delete $param{source};
379 if (exists $param{maintainer}) {
380 $param{maint} = [exists $param{maint}?make_list($param{maint}):(),
381 make_list($param{maintainer}),
383 delete $param{maintainer};
385 my $has_options = keys %options;
387 for my $type (qw(src package)) {
388 next unless exists $param{$type};
389 for my $target (make_list($param{$type})) {
391 if ($target =~ s/^src://) {
393 } elsif ($t_type eq 'source') {
394 $target = 'src:'.$target;
398 (munge_url('pkgreport.cgi?',
405 ('pkgreport.cgi?'.$t_type.'='.uri_escape_utf8($target),
410 for my $type (qw(maint owner submitter correspondent)) {
411 next unless exists $param{$type};
412 for my $target (make_list($param{$type})) {
413 my $addr = getparsedaddrs($target);
414 $addr = defined $addr?$addr->address:'';
417 (munge_url('pkgreport.cgi?',
424 $type.'='.uri_escape_utf8($target),
430 my ($link,$link_name);
432 if (length $param{class}) {
433 $class = q( class=").html_escape($param{class}).q(");
435 while (($link,$link_name) = splice(@links,0,2)) {
436 if ($param{links_only}) {
442 html_escape($link).q(">).
443 html_escape($link_name).q(</a>);
450 return join($param{separator},@return);
456 join(', ', bug_links(bug => \@packages))
458 Given a list of bugs, return a list of html which links to the bugs
462 =item bug -- arrayref or scalar of bug(s)
464 =item links_only -- return only links, not htmlized links, defaults to
465 returning htmlized links.
467 =item class -- class of the a href, defaults to ''
474 state $spec = {bug => {type => SCALAR|ARRAYREF,
477 links_only => {type => BOOLEAN,
480 class => {type => SCALAR,
483 separator => {type => SCALAR,
486 options => {type => HASHREF,
490 my %param = validate_with(params => \@_,
493 my %options = %{$param{options}};
496 delete $options{$_} if exists $options{$_};
498 my $has_options = keys %options;
501 push @links, map {(munge_url('bugreport.cgi?',
506 } make_list($param{bug}) if exists $param{bug};
509 map {my $b = ceil($_);
510 ('bugreport.cgi?bug='.$b,
512 grep {looks_like_number($_)}
513 make_list($param{bug}) if exists $param{bug};
516 my ($link,$link_name);
518 if (length $param{class}) {
519 $class = q( class=").html_escape($param{class}).q(");
521 while (($link,$link_name) = splice(@links,0,2)) {
522 if ($param{links_only}) {
528 html_escape($link).q(">).
529 html_escape($link_name).q(</a>);
536 return join($param{separator},@return);
545 maybelink('http://foobarbaz,http://bleh',qr/[, ]+/);
546 maybelink('http://foobarbaz,http://bleh',qr/[, ]+/,', ');
549 In the first form, links the link if it looks like a link. In the
550 second form, first splits based on the regex, then reassembles the
551 link, linking things that look like links. In the third form, rejoins
552 the split links with commas and spaces.
557 my ($links,$regex,$join) = @_;
558 if (not defined $regex and not defined $join) {
559 $links =~ s{(.*?)((?:(?:ftp|http|https)://[\S~-]+?/?)?)([\)\'\:\.\,]?(?:\s|\.<|$))}
560 {html_escape($1).(length $2?q(<a href=").html_escape($2).q(">).html_escape($2).q(</a>):'').html_escape($3)}geimo;
563 $join = ' ' if not defined $join;
566 if (defined $regex) {
567 @segments = split $regex, $links;
570 @segments = ($links);
572 for my $in (@segments) {
573 if ($in =~ /^[a-zA-Z0-9+.-]+:/) { # RFC 1738 scheme
574 push @return, qq{<a href="$in">} . html_escape($in) . '</a>';
576 push @return, html_escape($in);
579 return @return?join($join,@return):'';
583 =head2 htmlize_addresslinks
585 htmlize_addresslinks($prefixfunc,$urlfunc,$addresses,$class);
588 Generate a comma-separated list of HTML links to each address given in
589 $addresses, which should be a comma-separated list of RFC822
590 addresses. $urlfunc should be a reference to a function like mainturl
591 or submitterurl which returns the URL for each individual address.
596 sub htmlize_addresslinks {
597 my ($prefixfunc, $urlfunc, $addresses,$class) = @_;
598 carp "htmlize_addresslinks is deprecated";
600 $class = defined $class?qq(class="$class" ):'';
601 if (defined $addresses and $addresses ne '') {
602 my @addrs = getparsedaddrs($addresses);
603 my $prefix = (ref $prefixfunc) ?
604 $prefixfunc->(scalar @addrs):$prefixfunc;
607 { sprintf qq(<a ${class}).
609 $urlfunc->($_->address),
610 html_escape($_->format) ||
616 my $prefix = (ref $prefixfunc) ?
617 $prefixfunc->(1) : $prefixfunc;
618 return sprintf '%s<a '.$class.'href="%s">(unknown)</a>',
619 $prefix, $urlfunc->('');
624 my $addr = getparsedaddrs($_[0] || "");
625 $addr = defined $addr?$addr->address:'';
629 sub mainturl { package_links(maintainer => $_[0], links_only => 1); }
630 sub submitterurl { package_links(submitter => $_[0], links_only => 1); }
631 sub htmlize_maintlinks {
632 my ($prefixfunc, $maints) = @_;
633 carp "htmlize_maintlinks is deprecated";
634 return htmlize_addresslinks($prefixfunc, \&mainturl, $maints);
639 bug_linklist($separator,$class,@bugs)
641 Creates a set of links to C<@bugs> separated by C<$separator> with
642 link class C<$class>.
644 XXX Use L<Params::Validate>; we want to be able to support query
645 arguments here too; we should be able to combine bug_links and this
652 my ($sep,$class,@bugs) = @_;
653 carp "bug_linklist is deprecated; use bug_links instead";
654 return scalar bug_links(bug=>\@bugs,class=>$class,separator=>$sep);
659 my ($user,$usertags,$bug_usertags,$seen_users,$cats,$hidden) = @_;
660 $seen_users = {} if not defined $seen_users;
661 $bug_usertags = {} if not defined $bug_usertags;
662 $usertags = {} if not defined $usertags;
663 $cats = {} if not defined $cats;
664 $hidden = {} if not defined $hidden;
665 return if exists $seen_users->{$user};
666 $seen_users->{$user} = 1;
668 my $u = Debbugs::User::get_user($user);
670 my %vis = map { $_, 1 } @{$u->{"visible_cats"}};
671 for my $c (keys %{$u->{"categories"}}) {
672 $cats->{$c} = $u->{"categories"}->{$c};
673 $hidden->{$c} = 1 unless defined $vis{$c};
675 for my $t (keys %{$u->{"tags"}}) {
676 $usertags->{$t} = [] unless defined $usertags->{$t};
677 push @{$usertags->{$t}}, @{$u->{"tags"}->{$t}};
680 %{$bug_usertags} = ();
681 for my $t (keys %{$usertags}) {
682 for my $b (@{$usertags->{$t}}) {
683 $bug_usertags->{$b} = [] unless defined $bug_usertags->{$b};
684 push @{$bug_usertags->{$b}}, $t;
695 =head2 form_options_and_normal_param
697 my ($form_option,$param) = form_options_and_normal_param(\%param)
698 if $param{form_options};
699 my $form_option = form_options_and_normal_param(\%param)
700 if $param{form_options};
702 Translates from special form_options to a set of parameters which can
703 be used to run the current page.
705 The idea behind this is to allow complex forms to relatively easily
706 cause options that the existing cgi scripts understand to be set.
708 Currently there are two commands which are understood:
709 combine, and concatenate.
713 Combine works by entering key,value pairs into the parameters using
714 the key field option input field, and the value field option input
717 For example, you would have
719 <input type="hidden" name="_fo_combine_key_fo_searchkey_value_fo_searchvalue" value="1">
721 which would combine the _fo_searchkey and _fo_searchvalue input fields, so
723 <input type="text" name="_fo_searchkey" value="foo">
724 <input type="text" name="_fo_searchvalue" value="bar">
726 would yield foo=>'bar' in %param.
730 Concatenate concatenates values into a single entry in a parameter
732 For example, you would have
734 <input type="hidden" name="_fo_concatentate_into_foo_with_:_fo_blah_fo_bleargh" value="1">
736 which would combine the _fo_searchkey and _fo_searchvalue input fields, so
738 <input type="text" name="_fo_blah" value="bar">
739 <input type="text" name="_fo_bleargh" value="baz">
741 would yield foo=>'bar:baz' in %param.
746 my $form_option_leader = '_fo_';
747 sub form_options_and_normal_param{
748 my ($orig_param) = @_;
749 # all form_option parameters start with _fo_
750 my ($param,$form_option) = ({},{});
751 for my $key (keys %{$orig_param}) {
752 if ($key =~ /^\Q$form_option_leader\E/) {
753 $form_option->{$key} = $orig_param->{$key};
756 $param->{$key} = $orig_param->{$key};
759 # at this point, we check for commands
760 COMMAND: for my $key (keys %{$form_option}) {
761 $key =~ s/^\Q$form_option_leader\E//;
762 if (my ($key_name,$value_name) =
763 $key =~ /combine_key(\Q$form_option_leader\E.+)
764 _value(\Q$form_option_leader\E.+)$/x
766 next unless defined $form_option->{$key_name};
767 next unless defined $form_option->{$value_name};
768 my @keys = make_list($form_option->{$key_name});
769 my @values = make_list($form_option->{$value_name});
770 for my $i (0 .. $#keys) {
771 last if $i > $#values;
772 next if not defined $keys[$i];
773 next if not defined $values[$i];
774 __add_to_param($param,
780 elsif (my ($field,$concatenate_key,$fields) =
781 $key =~ /concatenate_into_(.+?)((?:_with_[^_])?)
782 ((?:\Q$form_option_leader\E.+?)+)
785 if (length $concatenate_key) {
786 $concatenate_key =~ s/_with_//;
789 $concatenate_key = ':';
791 my @fields = $fields =~ m/(\Q$form_option_leader\E.+?)(?:(?=\Q$form_option_leader\E)|$)/g;
794 for my $f (@fields) {
795 next COMMAND unless defined $form_option->{$f};
796 $field_list{$f} = [make_list($form_option->{$f})];
797 $max_num = max($max_num,$#{$field_list{$f}});
799 for my $i (0 .. $max_num) {
800 next unless @fields == grep {$i <= $#{$field_list{$_}} and
801 defined $field_list{$_}[$i]} @fields;
802 __add_to_param($param,
804 join($concatenate_key,
805 map {$field_list{$_}[$i]} @fields
811 return wantarray?($form_option,$param):$form_option;
816 print option_form(template=>'pkgreport_options',
818 form_options => $form_options,
826 my %param = validate_with(params => \@_,
827 spec => {template => {type => SCALAR,
829 variables => {type => HASHREF,
832 language => {type => SCALAR,
835 param => {type => HASHREF,
838 form_options => {type => HASHREF,
844 # First, we need to see if we need to add particular types of
846 my $variables = dclone($param{variables});
847 $variables->{param} = dclone($param{param});
848 for my $key (keys %{$param{form_option}}) {
849 # strip out leader; shouldn't be anything here without one,
850 # but skip stupid things anyway
851 next unless $key =~ s/^\Q$form_option_leader\E//;
852 if ($key =~ /^add_(.+)$/) {
853 # this causes a specific parameter to be added
854 __add_to_param($variables->{param},
859 elsif ($key =~ /^delete_(.+?)(?:_(\d+))?$/) {
860 next unless exists $variables->{param}{$1};
861 if (ref $variables->{param}{$1} eq 'ARRAY' and
863 defined $variables->{param}{$1}[$2]
865 splice @{$variables->{param}{$1}},$2,1;
868 delete $variables->{param}{$1};
871 # we'll add extra comands here once I figure out what they
874 # now at this point, we're ready to create the template
875 return Debbugs::Text::fill_in_template(template=>$param{template},
876 (exists $param{language}?(language=>$param{language}):()),
877 variables => $variables,
878 hole_var => {'&html_escape' => \&html_escape,
884 my ($param,$key,@values) = @_;
886 if (exists $param->{$key} and not
887 ref $param->{$key}) {
888 @{$param->{$key}} = [$param->{$key},
893 push @{$param->{$key}}, @values;
907 Decodes the funky maintainer encoding.
909 Don't ask me what in the world it does.
915 return () unless @input;
917 for my $input (@input) {
918 my $decoded = $input;
919 $decoded =~ s/-([^_]+)/-$1_-/g;
920 $decoded =~ s/_/-20_/g;
921 $decoded =~ s/^,(.*),(.*),([^,]+)$/$1-40_$2-20_-28_$3-29_/;
922 $decoded =~ s/^([^,]+),(.*),(.*),/$1-20_-3c_$2-40_$3-3e_/;
923 $decoded =~ s/\./-2e_/g;
924 $decoded =~ s/-([0-9a-f]{2})_/pack('H*',$1)/ge;
925 push @output,$decoded;
927 wantarray ? @output : $output[0];
932 =head2 calculate_etags
934 calculate_etags(files => [qw(list of files)],additional_data => [qw(any additional data)]);
938 sub calculate_etags {
940 validate_with(params => \@_,
941 spec => {files => {type => ARRAYREF,
944 additional_data => {type => ARRAYREF,
949 my @additional_data = @{$param{additional_data}};
950 for my $file (@{$param{files}}) {
951 my $st = stat($file) or warn "Unable to stat $file: $!";
952 push @additional_data,$st->mtime;
953 push @additional_data,$st->size;
955 return(md5_hex(join('',sort @additional_data)));
958 =head2 etag_does_not_match
960 etag_does_not_match(cgi=>$q,files=>[qw(list of files)],
961 additional_data=>[qw(any additional data)])
964 Checks to see if the CGI request contains an etag which matches the calculated
967 If there wasn't an etag given, or the etag given doesn't match, return the etag.
969 If the etag does match, return 0.
973 sub etag_does_not_match {
975 validate_with(params => \@_,
976 spec => {files => {type => ARRAYREF,
979 additional_data => {type => ARRAYREF,
982 cgi => {type => OBJECT},
986 $param{cgi}->http('if-none-match');
988 calculate_etags(files=>$param{files},
989 additional_data=>$param{additional_data});
990 if (not defined $submitted_etag or
991 length($submitted_etag) != 32
992 or $etag ne $submitted_etag
996 if ($etag eq $submitted_etag) {