Debbugs/CGI.pm

   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.
   5 #
   6 # [Other people have contributed to this file; their copyrights should
   7 # go here too.]
   8 # Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
   9
  10 package Debbugs::CGI;
  11
  12 =head1 NAME
  13
  14 Debbugs::CGI -- General routines for the cgi scripts
  15
  16 =head1 SYNOPSIS
  17
  18 use Debbugs::CGI qw(:url :html);
  19
  20 html_escape(bug_url($ref,mbox=>'yes',mboxstatus=>'yes'));
  21
  22 =head1 DESCRIPTION
  23
  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.
  27
  28 =head1 BUGS
  29
  30 None known.
  31
  32 =cut
  33
  34 use warnings;
  35 use strict;
  36 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
  37 use base qw(Exporter);
  38 use Debbugs::URI;
  39 use HTML::Entities;
  40 use Debbugs::Common qw(getparsedaddrs);
  41 use Params::Validate qw(validate_with :types);
  42 use Debbugs::Config qw(:config);
  43 use Debbugs::Status qw(splitpackages);
  44 use Mail::Address;
  45 use POSIX qw(ceil);
  46 use Storable qw(dclone);
  47
  48 our %URL_PARAMS = ();
  49
  50
  51 BEGIN{
  52      ($VERSION) = q$Revision: 1.3 $ =~ /^Revision:\s+([^\s+])/;
  53      $DEBUG = 0 unless defined $DEBUG;
  54
  55      @EXPORT = ();
  56      %EXPORT_TAGS = (url    => [qw(bug_url bug_links bug_linklist maybelink),
  57                                 qw(set_url_params pkg_url version_url),
  58                                 qw(submitterurl mainturl)
  59                                ],
  60                      html   => [qw(html_escape htmlize_bugs htmlize_packagelinks),
  61                                 qw(maybelink htmlize_addresslinks htmlize_maintlinks),
  62                                ],
  63                      util   => [qw(cgi_parameters quitcgi),
  64                                 qw(getpseudodesc)
  65                                ],
  66                      #status => [qw(getbugstatus)],
  67                     );
  68      @EXPORT_OK = ();
  69      Exporter::export_ok_tags(qw(url html util));
  70      $EXPORT_TAGS{all} = [@EXPORT_OK];
  71 }
  72
  73
  74
  75 =head2 set_url_params
  76
  77      set_url_params($uri);
  78
  79
  80 Sets the url params which will be used to generate urls.
  81
  82 =cut
  83
  84 sub set_url_params{
  85      if (@_ > 1) {
  86           %URL_PARAMS = @_;
  87      }
  88      else {
  89           my $url = Debbugs::URI->new($_[0]||'');
  90           %URL_PARAMS = %{$url->query_form_hash};
  91      }
  92 }
  93
  94
  95 =head2 bug_url
  96
  97      bug_url($ref,mbox=>'yes',mboxstat=>'yes');
  98
  99 Constructs urls which point to a specific
 100
 101 XXX use Params::Validate
 102
 103 =cut
 104
 105 sub bug_url{
 106      my $ref = shift;
 107      my %params;
 108      if (@_ % 2) {
 109           shift;
 110           %params = (%URL_PARAMS,@_);
 111      }
 112      else {
 113           %params = @_;
 114      }
 115      my $url = Debbugs::URI->new('bugreport.cgi?');
 116      $url->query_form(bug=>$ref,%params);
 117      return $url->as_string;
 118 }
 119
 120 sub pkg_url{
 121      my %params;
 122      if (@_ % 2) {
 123           shift;
 124           %params = (%URL_PARAMS,@_);
 125      }
 126      else {
 127           %params = @_;
 128      }
 129      my $url = Debbugs::URI->new('pkgreport.cgi?');
 130      $url->query_form(%params);
 131      return $url->as_string;
 132 }
 133
 134 =head2 version_url
 135
 136      version_url($package,$found,$fixed)
 137
 138 Creates a link to the version cgi script
 139
 140 =cut
 141
 142 sub version_url{
 143      my ($package,$found,$fixed,$width,$height) = @_;
 144      my $url = Debbugs::URI->new('version.cgi?');
 145      $url->query_form(package => $package,
 146                       found   => $found,
 147                       fixed   => $fixed,
 148                       (defined $width)?(width => $width):(),
 149                       (defined $height)?(height => $height):(),
 150                       (defined $width or defined $height)?(collapse => 1):(),
 151                      );
 152      return $url->as_string;
 153 }
 154
 155 =head2 html_escape
 156
 157      html_escape($string)
 158
 159 Escapes html entities by calling HTML::Entities::encode_entities;
 160
 161 =cut
 162
 163 sub html_escape{
 164      my ($string) = @_;
 165
 166      return HTML::Entities::encode_entities($string,q(<>&"'));
 167 }
 168
 169 =head2 cgi_parameters
 170
 171      cgi_parameters
 172
 173 Returns all of the cgi_parameters from a CGI script using CGI::Simple
 174
 175 =cut
 176
 177 sub cgi_parameters {
 178      my %options = validate_with(params => \@_,
 179                                  spec   => {query   => {type => OBJECT,
 180                                                         can  => 'param',
 181                                                        },
 182                                             single  => {type => ARRAYREF,
 183                                                         default => [],
 184                                                        },
 185                                             default => {type => HASHREF,
 186                                                         default => {},
 187                                                        },
 188                                            },
 189                                 );
 190      my $q = $options{query};
 191      my %single;
 192      @single{@{$options{single}}} = (1) x @{$options{single}};
 193      my %param;
 194      for my $paramname ($q->param) {
 195           if ($single{$paramname}) {
 196                $param{$paramname} = $q->param($paramname);
 197           }
 198           else {
 199                $param{$paramname} = [$q->param($paramname)];
 200           }
 201      }
 202      for my $default (keys %{$options{default}}) {
 203           if (not exists $param{$default}) {
 204                # We'll clone the reference here to avoid surprises later.
 205                $param{$default} = ref($options{default}{$default})?
 206                     dclone($options{default}{$default}):$options{default}{$default};
 207           }
 208      }
 209      return %param;
 210 }
 211
 212
 213 sub quitcgi {
 214     my $msg = shift;
 215     print "Content-Type: text/html\n\n";
 216     print "<HTML><HEAD><TITLE>Error</TITLE></HEAD><BODY>\n";
 217     print "An error occurred. Dammit.\n";
 218     print "Error was: $msg.\n";
 219     print "</BODY></HTML>\n";
 220     exit 0;
 221 }
 222
 223
 224 =head HTML
 225
 226 =head2 htmlize_bugs
 227
 228      htmlize_bugs({bug=>1,status=>\%status,extravars=>\%extra},{bug=>...}});
 229
 230 Turns a list of bugs into an html snippit of the bugs.
 231
 232 =cut
 233 #     htmlize_bugs(bugs=>[@bugs]);
 234 sub htmlize_bugs{
 235      my @bugs = @_;
 236      my @html;
 237
 238      for my $bug (@bugs) {
 239           my $html = sprintf "<li><a href=\"%s\">#%d: %s</a>\n<br>",
 240                bug_url($bug->{bug}), $bug->{bug}, html_escape($bug->{status}{subject});
 241           $html .= htmlize_bugstatus($bug->{status}) . "\n";
 242      }
 243      return @html;
 244 }
 245
 246
 247 sub htmlize_bugstatus {
 248      my %status = %{$_[0]};
 249
 250      my $result = "";
 251
 252      my $showseverity;
 253      if  ($status{severity} eq $config{default_severity}) {
 254           $showseverity = '';
 255      } elsif (isstrongseverity($status{severity})) {
 256           $showseverity = "Severity: <em class=\"severity\">$status{severity}</em>;\n";
 257      } else {
 258           $showseverity = "Severity: <em>$status{severity}</em>;\n";
 259      }
 260
 261      $result .= htmlize_packagelinks($status{"package"}, 1);
 262
 263      my $showversions = '';
 264      if (@{$status{found_versions}}) {
 265           my @found = @{$status{found_versions}};
 266           local $_;
 267           s{/}{ } foreach @found;
 268           $showversions .= join ', ', map html_escape($_), @found;
 269      }
 270      if (@{$status{fixed_versions}}) {
 271           $showversions .= '; ' if length $showversions;
 272           $showversions .= '<strong>fixed</strong>: ';
 273           my @fixed = @{$status{fixed_versions}};
 274           $showversions .= join ', ', map {s#/##; html_escape($_)} @fixed;
 275      }
 276      $result .= " ($showversions)" if length $showversions;
 277      $result .= ";\n";
 278
 279      $result .= $showseverity;
 280      $result .= htmlize_addresslinks("Reported by: ", \&submitterurl,
 281                                 $status{originator});
 282      $result .= ";\nOwned by: " . html_escape($status{owner})
 283           if length $status{owner};
 284      $result .= ";\nTags: <strong>"
 285           . html_escape(join(", ", sort(split(/\s+/, $status{tags}))))
 286                . "</strong>"
 287                     if (length($status{tags}));
 288
 289      $result .= ";\nMerged with ".
 290           bug_linklist(', ',
 291                        'submitter',
 292                        split(/ /,$status{mergedwith}))
 293                if length $status{mergedwith};
 294      $result .= ";\nBlocked by ".
 295           bug_linklist(", ",
 296                        'submitter',
 297                        split(/ /,$status{blockedby}))
 298                if length $status{blockedby};
 299      $result .= ";\nBlocks ".
 300           bug_linklist(", ",
 301                        'submitter',
 302                        split(/ /,$status{blocks})
 303                       )
 304                if length $status{blocks};
 305
 306      my $days = 0;
 307      if (length($status{done})) {
 308           $result .= "<br><strong>Done:</strong> " . html_escape($status{done});
 309           $days = ceil($debbugs::gRemoveAge - -M buglog($status{id}));
 310           if ($days >= 0) {
 311                $result .= ";\n<strong>Will be archived" . ( $days == 0 ? " today" : $days == 1 ? " in $days day" : " in $days days" ) . "</strong>";
 312           } else {
 313                $result .= ";\n<strong>Archived</strong>";
 314           }
 315      }
 316      else {
 317           if (length($status{forwarded})) {
 318                $result .= ";\n<strong>Forwarded</strong> to "
 319                     . maybelink($status{forwarded});
 320           }
 321           my $daysold = int((time - $status{date}) / 86400);   # seconds to days
 322           if ($daysold >= 7) {
 323                my $font = "";
 324                my $efont = "";
 325                $font = "em" if ($daysold > 30);
 326                $font = "strong" if ($daysold > 60);
 327                $efont = "</$font>" if ($font);
 328                $font = "<$font>" if ($font);
 329
 330                my $yearsold = int($daysold / 365);
 331                $daysold -= $yearsold * 365;
 332
 333                $result .= ";\n $font";
 334                my @age;
 335                push @age, "1 year" if ($yearsold == 1);
 336                push @age, "$yearsold years" if ($yearsold > 1);
 337                push @age, "1 day" if ($daysold == 1);
 338                push @age, "$daysold days" if ($daysold > 1);
 339                $result .= join(" and ", @age);
 340                $result .= " old$efont";
 341         }
 342     }
 343
 344     $result .= ".";
 345
 346     return $result;
 347 }
 348
 349 =head2 htmlize_packagelinks
 350
 351      htmlize_packagelinks
 352
 353 Given a scalar containing a list of packages separated by something
 354 that L<Debbugs::CGI/splitpackages> can separate, returns a
 355 formatted set of links to packages.
 356
 357 =cut
 358
 359 sub htmlize_packagelinks {
 360     my ($pkgs,$strong) = @_;
 361     return unless defined $pkgs and $pkgs ne '';
 362     my @pkglist = splitpackages($pkgs);
 363
 364     $strong = 0;
 365     my $openstrong  = $strong ? '<strong>' : '';
 366     my $closestrong = $strong ? '</strong>' : '';
 367
 368     return 'Package' . (@pkglist > 1 ? 's' : '') . ': ' .
 369            join(', ',
 370                 map {
 371                     '<a class="submitter" href="' . pkg_url(pkg=>$_||'') . '">' .
 372                     $openstrong . html_escape($_) . $closestrong . '</a>'
 373                 } @pkglist
 374            );
 375 }
 376
 377
 378 =head2 maybelink
 379
 380      maybelink($in);
 381      maybelink('http://foobarbaz,http://bleh',qr/[, ]+/);
 382      maybelink('http://foobarbaz,http://bleh',qr/[, ]+/,', ');
 383
 384
 385 In the first form, links the link if it looks like a link. In the
 386 second form, first splits based on the regex, then reassembles the
 387 link, linking things that look like links. In the third form, rejoins
 388 the split links with commas and spaces.
 389
 390 =cut
 391
 392 sub maybelink {
 393     my ($links,$regex,$join) = @_;
 394     $join = ' ' if not defined $join;
 395     my @return;
 396     my @segments;
 397     if (defined $regex) {
 398          @segments = split $regex, $links;
 399     }
 400     else {
 401          @segments = ($links);
 402     }
 403     for my $in (@segments) {
 404          if ($in =~ /^[a-zA-Z0-9+.-]+:/) { # RFC 1738 scheme
 405               push @return, qq{<a href="$in">} . html_escape($in) . '</a>';
 406          } else {
 407               push @return, html_escape($in);
 408          }
 409     }
 410     return @return?join($join,@return):'';
 411 }
 412
 413
 414 =head2 htmlize_addresslinks
 415
 416      htmlize_addresslinks($prefixfunc,$urlfunc,$addresses,$class);
 417
 418
 419 Generate a comma-separated list of HTML links to each address given in
 420 $addresses, which should be a comma-separated list of RFC822
 421 addresses. $urlfunc should be a reference to a function like mainturl
 422 or submitterurl which returns the URL for each individual address.
 423
 424
 425 =cut
 426
 427 sub htmlize_addresslinks {
 428      my ($prefixfunc, $urlfunc, $addresses,$class) = @_;
 429      $class = defined $class?qq(class="$class" ):'';
 430      if (defined $addresses and $addresses ne '') {
 431           my @addrs = getparsedaddrs($addresses);
 432           my $prefix = (ref $prefixfunc) ?
 433                $prefixfunc->(scalar @addrs):$prefixfunc;
 434           return $prefix .
 435                join(', ', map
 436                     { sprintf qq(<a ${class}).
 437                            'href="%s">%s</a>',
 438                                 $urlfunc->($_->address),
 439                                      html_escape($_->format) ||
 440                                           '(unknown)'
 441                                      } @addrs
 442                    );
 443      }
 444      else {
 445           my $prefix = (ref $prefixfunc) ?
 446                $prefixfunc->(1) : $prefixfunc;
 447           return sprintf '%s<a '.$class.'href="%s">(unknown)</a>',
 448                $prefix, $urlfunc->('');
 449      }
 450 }
 451
 452 sub emailfromrfc822{
 453      my $addr = getparsedaddrs($_[0] || "");
 454      $addr = defined $addr?$addr->address:'';
 455      return $addr;
 456 }
 457
 458 sub mainturl { pkg_url(maint => emailfromrfc822($_[0])); }
 459 sub submitterurl { pkg_url(submitter => emailfromrfc822($_[0])); }
 460 sub htmlize_maintlinks {
 461     my ($prefixfunc, $maints) = @_;
 462     return htmlize_addresslinks($prefixfunc, \&mainturl, $maints);
 463 }
 464
 465
 466 our $_maintainer;
 467 our $_maintainer_rev;
 468
 469 our $_pseudodesc;
 470 sub getpseudodesc {
 471     return $_pseudodesc if $_pseudodesc;
 472     my %pseudodesc;
 473
 474     my $pseudo = new IO::File $config{pseudo_desc_file},'r'
 475          or &quitcgi("Unable to open $config{pseudo_desc_file}: $!");
 476     while(<$pseudo>) {
 477         next unless m/^(\S+)\s+(\S.*\S)\s*$/;
 478         $pseudodesc{lc $1} = $2;
 479     }
 480     close($pseudo);
 481     $_pseudodesc = \%pseudodesc;
 482     return $_pseudodesc;
 483 }
 484
 485
 486 =head2 bug_links
 487
 488      bug_links($one_bug);
 489      bug_links($starting_bug,$stoping_bugs,);
 490
 491 Creates a set of links to bugs, starting with bug number
 492 $starting_bug, and finishing with $stoping_bug; if only one bug is
 493 passed, makes a link to only a single bug.
 494
 495 The content of the link is the bug number.
 496
 497 XXX Use L<Params::Validate>; we want to be able to support query
 498 arguments here too.
 499
 500 =cut
 501
 502 sub bug_links{
 503      my ($start,$stop,$query_arguments) = @_;
 504      $stop = $stop || $start;
 505      $query_arguments ||= '';
 506      my @output;
 507      for my $bug ($start..$stop) {
 508           push @output,'<a href="'.bug_url($bug,'').qq(">$bug</a>);
 509      }
 510      return join(', ',@output);
 511 }
 512
 513 =head2 bug_linklist
 514
 515      bug_linklist($separator,$class,@bugs)
 516
 517 Creates a set of links to C<@bugs> separated by C<$separator> with
 518 link class C<$class>.
 519
 520 XXX Use L<Params::Validate>; we want to be able to support query
 521 arguments here too; we should be able to combine bug_links and this
 522 function into one. [Hell, bug_url should be one function with this one
 523 too.]
 524
 525 =cut
 526
 527
 528 sub bug_linklist{
 529      my ($sep,$class,@bugs) = @_;
 530      if (length $class) {
 531           $class = qq(class="$class" );
 532      }
 533      return join($sep,map{qq(<a ${class}href=").
 534                                bug_url($_).qq(">#$_</a>)
 535                           } @bugs);
 536 }
 537
 538
 539
 540
 541 1;
 542
 543
 544 __END__
 545
 546
 547
 548
 549
 550