Debbugs/CGI.pm

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