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