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);
50 use Debbugs::Text qw(fill_in_template);
56 ($VERSION) = q$Revision: 1.3 $ =~ /^Revision:\s+([^\s+])/;
57 $DEBUG = 0 unless defined $DEBUG;
60 %EXPORT_TAGS = (url => [qw(bug_url bug_links bug_linklist maybelink),
61 qw(set_url_params pkg_url version_url),
62 qw(submitterurl mainturl munge_url),
63 qw(package_links bug_links),
65 html => [qw(html_escape htmlize_bugs htmlize_packagelinks),
66 qw(maybelink htmlize_addresslinks htmlize_maintlinks),
68 util => [qw(cgi_parameters quitcgi),
70 misc => [qw(maint_decode)],
71 #status => [qw(getbugstatus)],
74 Exporter::export_ok_tags(qw(url html util misc));
75 $EXPORT_TAGS{all} = [@EXPORT_OK];
85 Sets the url params which will be used to generate urls.
94 my $url = Debbugs::URI->new($_[0]||'');
95 %URL_PARAMS = %{$url->query_form_hash};
102 bug_url($ref,mbox=>'yes',mboxstat=>'yes');
104 Constructs urls which point to a specific
106 XXX use Params::Validate
115 %params = (%URL_PARAMS,@_);
120 return munge_url('bugreport.cgi?',%params,bug=>$ref);
127 %params = (%URL_PARAMS,@_);
132 return munge_url('pkgreport.cgi?',%params);
137 my $url = munge_url($url,%params_to_munge);
139 Munges a url, replacing parameters with %params_to_munge as appropriate.
146 my $new_url = Debbugs::URI->new($url);
147 my @old_param = $new_url->query_form();
149 while (my ($key,$value) = splice @old_param,0,2) {
150 push @new_param,($key,$value) unless exists $params{$key};
152 $new_url->query_form(@new_param,%params);
153 return $new_url->as_string;
159 version_url(package => $package,found => $found,fixed => $fixed)
161 Creates a link to the version cgi script
165 =item package -- source package whose graph to display
167 =item found -- arrayref of found versions
169 =item fixed -- arrayref of fixed versions
171 =item width -- optional width of graph
173 =item height -- optional height of graph
175 =item info -- display html info surrounding graph; defaults to 1 if
176 width and height are not passed.
178 =item collapse -- whether to collapse the graph; defaults to 1 if
179 width and height are passed.
186 my %params = validate_with(params => \@_,
187 spec => {package => {type => SCALAR,
189 found => {type => ARRAYREF,
192 fixed => {type => ARRAYREF,
195 width => {type => SCALAR,
198 height => {type => SCALAR,
201 absolute => {type => BOOLEAN,
204 collapse => {type => BOOLEAN,
207 info => {type => BOOLEAN,
212 if (not defined $params{width} and not defined $params{height}) {
213 $params{info} = 1 if not exists $params{info};
215 my $url = Debbugs::URI->new('version.cgi?');
216 $url->query_form(%params);
217 return $url->as_string;
224 Escapes html entities by calling HTML::Entities::encode_entities;
231 return HTML::Entities::encode_entities($string,q(<>&"'));
234 =head2 cgi_parameters
238 Returns all of the cgi_parameters from a CGI script using CGI::Simple
243 my %options = validate_with(params => \@_,
244 spec => {query => {type => OBJECT,
247 single => {type => ARRAYREF,
250 default => {type => HASHREF,
255 my $q = $options{query};
257 @single{@{$options{single}}} = (1) x @{$options{single}};
259 for my $paramname ($q->param) {
260 if ($single{$paramname}) {
261 $param{$paramname} = $q->param($paramname);
264 $param{$paramname} = [$q->param($paramname)];
267 for my $default (keys %{$options{default}}) {
268 if (not exists $param{$default}) {
269 # We'll clone the reference here to avoid surprises later.
270 $param{$default} = ref($options{default}{$default})?
271 dclone($options{default}{$default}):$options{default}{$default};
280 print "Content-Type: text/html\n\n";
281 print fill_in_template(template=>'cgi/quit',
282 variables => {msg => $msg}
290 =head2 htmlize_packagelinks
294 Given a scalar containing a list of packages separated by something
295 that L<Debbugs::CGI/splitpackages> can separate, returns a
296 formatted set of links to packages.
300 sub htmlize_packagelinks {
302 return '' unless defined $pkgs and $pkgs ne '';
303 my @pkglist = splitpackages($pkgs);
305 carp "htmlize_packagelinks is deprecated";
307 return 'Package' . (@pkglist > 1 ? 's' : '') . ': ' .
309 package_links(package =>\@pkglist,
317 join(', ', package_links(packages => \@packages))
319 Given a list of packages, return a list of html which links to the package
323 =item package -- arrayref or scalar of package(s)
325 =item submitter -- arrayref or scalar of submitter(s)
327 =item source -- arrayref or scalar of source(s)
329 =item maintainer -- arrayref or scalar of maintainer(s)
331 =item links_only -- return only links, not htmlized links, defaults to
332 returning htmlized links.
334 =item class -- class of the a href, defaults to ''
341 my %param = validate_with(params => \@_,
342 spec => {package => {type => SCALAR|ARRAYREF,
345 source => {type => SCALAR|ARRAYREF,
348 maintainer => {type => SCALAR|ARRAYREF,
351 submitter => {type => SCALAR|ARRAYREF,
354 owner => {type => SCALAR|ARRAYREF,
357 links_only => {type => BOOLEAN,
360 class => {type => SCALAR,
363 separator => {type => SCALAR,
369 push @links, map {(pkg_url(source => $_),$_)
370 } make_list($param{source}) if exists $param{source};
371 push @links, map {my $addr = getparsedaddrs($_);
372 $addr = defined $addr?$addr->address:'';
373 (pkg_url(maint => $addr),$_)
374 } make_list($param{maintainer}) if exists $param{maintainer};
375 push @links, map {my $addr = getparsedaddrs($_);
376 $addr = defined $addr?$addr->address:'';
377 (pkg_url(owner => $addr),$_)
378 } make_list($param{owner}) if exists $param{owner};
379 push @links, map {my $addr = getparsedaddrs($_);
380 $addr = defined $addr?$addr->address:'';
381 (pkg_url(submitter => $addr),$_)
382 } make_list($param{submitter}) if exists $param{submitter};
383 push @links, map {(pkg_url(pkg => $_),
385 } make_list($param{package}) if exists $param{package};
387 my ($link,$link_name);
389 if (length $param{class}) {
390 $class = q( class=").html_escape($param{class}).q(");
392 while (($link,$link_name) = splice(@links,0,2)) {
393 if ($param{links_only}) {
399 html_escape($link).q(">).
400 html_escape($link_name).q(</a>);
407 return join($param{separator},@return);
413 join(', ', bug_links(bug => \@packages))
415 Given a list of bugs, return a list of html which links to the bugs
419 =item bug -- arrayref or scalar of bug(s)
421 =item links_only -- return only links, not htmlized links, defaults to
422 returning htmlized links.
424 =item class -- class of the a href, defaults to ''
431 my %param = validate_with(params => \@_,
432 spec => {bug => {type => SCALAR|ARRAYREF,
435 links_only => {type => BOOLEAN,
438 class => {type => SCALAR,
444 push @links, map {(bug_url($_),$_)
445 } make_list($param{bug}) if exists $param{bug};
447 my ($link,$link_name);
449 if (length $param{class}) {
450 $class = q( class=").html_escape($param{class}).q(");
452 while (($link,$link_name) = splice(@links,0,2)) {
453 if ($param{links_only}) {
459 html_escape($link).q(">).
460 html_escape($link_name).q(</a>);
471 maybelink('http://foobarbaz,http://bleh',qr/[, ]+/);
472 maybelink('http://foobarbaz,http://bleh',qr/[, ]+/,', ');
475 In the first form, links the link if it looks like a link. In the
476 second form, first splits based on the regex, then reassembles the
477 link, linking things that look like links. In the third form, rejoins
478 the split links with commas and spaces.
483 my ($links,$regex,$join) = @_;
484 $join = ' ' if not defined $join;
487 if (defined $regex) {
488 @segments = split $regex, $links;
491 @segments = ($links);
493 for my $in (@segments) {
494 if ($in =~ /^[a-zA-Z0-9+.-]+:/) { # RFC 1738 scheme
495 push @return, qq{<a href="$in">} . html_escape($in) . '</a>';
497 push @return, html_escape($in);
500 return @return?join($join,@return):'';
504 =head2 htmlize_addresslinks
506 htmlize_addresslinks($prefixfunc,$urlfunc,$addresses,$class);
509 Generate a comma-separated list of HTML links to each address given in
510 $addresses, which should be a comma-separated list of RFC822
511 addresses. $urlfunc should be a reference to a function like mainturl
512 or submitterurl which returns the URL for each individual address.
517 sub htmlize_addresslinks {
518 my ($prefixfunc, $urlfunc, $addresses,$class) = @_;
519 carp "htmlize_addresslinks is deprecated";
521 $class = defined $class?qq(class="$class" ):'';
522 if (defined $addresses and $addresses ne '') {
523 my @addrs = getparsedaddrs($addresses);
524 my $prefix = (ref $prefixfunc) ?
525 $prefixfunc->(scalar @addrs):$prefixfunc;
528 { sprintf qq(<a ${class}).
530 $urlfunc->($_->address),
531 html_escape($_->format) ||
537 my $prefix = (ref $prefixfunc) ?
538 $prefixfunc->(1) : $prefixfunc;
539 return sprintf '%s<a '.$class.'href="%s">(unknown)</a>',
540 $prefix, $urlfunc->('');
545 my $addr = getparsedaddrs($_[0] || "");
546 $addr = defined $addr?$addr->address:'';
550 sub mainturl { pkg_url(maint => emailfromrfc822($_[0])); }
551 sub submitterurl { pkg_url(submitter => emailfromrfc822($_[0])); }
552 sub htmlize_maintlinks {
553 my ($prefixfunc, $maints) = @_;
554 carp "htmlize_maintlinks is deprecated";
555 return htmlize_addresslinks($prefixfunc, \&mainturl, $maints);
560 our $_maintainer_rev;
564 bug_linklist($separator,$class,@bugs)
566 Creates a set of links to C<@bugs> separated by C<$separator> with
567 link class C<$class>.
569 XXX Use L<Params::Validate>; we want to be able to support query
570 arguments here too; we should be able to combine bug_links and this
571 function into one. [Hell, bug_url should be one function with this one
578 my ($sep,$class,@bugs) = @_;
579 return join($sep,bug_links(bug=>\@bugs,class=>$class));
591 Decodes the funky maintainer encoding.
593 Don't ask me what in the world it does.
599 return () unless @input;
601 for my $input (@input) {
602 my $decoded = $input;
603 $decoded =~ s/-([^_]+)/-$1_-/g;
604 $decoded =~ s/_/-20_/g;
605 $decoded =~ s/^,(.*),(.*),([^,]+)$/$1-40_$2-20_-28_$3-29_/;
606 $decoded =~ s/^([^,]+),(.*),(.*),/$1-20_-3c_$2-40_$3-3e_/;
607 $decoded =~ s/\./-2e_/g;
608 $decoded =~ s/-([0-9a-f]{2})_/pack('H*',$1)/ge;
609 push @output,$decoded;
611 wantarray ? @output : $output[0];