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