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