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 Mail::Address;
  36 use POSIX qw(ceil);
  37 use Storable qw(dclone);
  38
  39 my %URL_PARAMS = ();
  40
  41
  42 BEGIN{
  43      ($VERSION) = q$Revision: 1.3 $ =~ /^Revision:\s+([^\s+])/;
  44      $DEBUG = 0 unless defined $DEBUG;
  45
  46      @EXPORT = ();
  47      %EXPORT_TAGS = (url    => [qw(bug_url bug_links bug_linklist maybelink),
  48                                 qw(set_url_params pkg_url version_url),
  49                                 qw(submitterurl mainturl)
  50                                ],
  51                      html   => [qw(html_escape htmlize_bugs htmlize_packagelinks),
  52                                 qw(maybelink htmlize_addresslinks htmlize_maintlinks),
  53                                ],
  54                      util   => [qw(cgi_parameters quitcgi),
  55                                 qw(getmaintainers getpseudodesc splitpackages)
  56                                ],
  57                      #status => [qw(getbugstatus)],
  58                     );
  59      @EXPORT_OK = ();
  60      Exporter::export_ok_tags(qw(url html util));
  61      $EXPORT_TAGS{all} = [@EXPORT_OK];
  62 }
  63
  64
  65
  66 =head2 set_url_params
  67
  68      set_url_params($uri);
  69
  70
  71 Sets the url params which will be used to generate urls.
  72
  73 =cut
  74
  75 sub set_url_params{
  76      if (@_ > 1) {
  77           %URL_PARAMS = @_;
  78      }
  79      else {
  80           my $url = Debbugs::URI->new($_[0]||'');
  81           %URL_PARAMS = %{$url->query_form_hash};
  82      }
  83 }
  84
  85
  86 =head2 bug_url
  87
  88      bug_url($ref,mbox=>'yes',mboxstat=>'yes');
  89
  90 Constructs urls which point to a specific
  91
  92 XXX use Params::Validate
  93
  94 =cut
  95
  96 sub bug_url{
  97      my $ref = shift;
  98      my %params;
  99      if (@_ % 2) {
 100           shift;
 101           %params = (%URL_PARAMS,@_);
 102      }
 103      else {
 104           %params = @_;
 105      }
 106      my $url = Debbugs::URI->new('bugreport.cgi?');
 107      $url->query_form(bug=>$ref,%params);
 108      return $url->as_string;
 109 }
 110
 111 sub pkg_url{
 112      my %params;
 113      if (@_ % 2) {
 114           shift;
 115           %params = (%URL_PARAMS,@_);
 116      }
 117      else {
 118           %params = @_;
 119      }
 120      my $url = Debbugs::URI->new('pkgreport.cgi?');
 121      $url->query_form(%params);
 122      return $url->as_string;
 123 }
 124
 125 =head2 version_url
 126
 127      version_url($package,$found,$fixed)
 128
 129 Creates a link to the version cgi script
 130
 131 =cut
 132
 133 sub version_url{
 134      my ($package,$found,$fixed) = @_;
 135      my $url = Debbugs::URI->new('version.cgi?');
 136      $url->query_form(package => $package,
 137                       found   => $found,
 138                       fixed   => $fixed,
 139                      );
 140      return $url->as_string;
 141 }
 142
 143 =head2 html_escape
 144
 145      html_escape($string)
 146
 147 Escapes html entities by calling HTML::Entities::encode_entities;
 148
 149 =cut
 150
 151 sub html_escape{
 152      my ($string) = @_;
 153
 154      return HTML::Entities::encode_entities($string)
 155 }
 156
 157 =head2 cgi_parameters
 158
 159      cgi_parameters
 160
 161 Returns all of the cgi_parameters from a CGI script using CGI::Simple
 162
 163 =cut
 164
 165 sub cgi_parameters {
 166      my %options = validate_with(params => \@_,
 167                                  spec   => {query   => {type => OBJECT,
 168                                                         can  => 'param',
 169                                                        },
 170                                             single  => {type => ARRAYREF,
 171                                                         default => [],
 172                                                        },
 173                                             default => {type => HASHREF,
 174                                                         default => {},
 175                                                        },
 176                                            },
 177                                 );
 178      my $q = $options{query};
 179      my %single;
 180      @single{@{$options{single}}} = (1) x @{$options{single}};
 181      my %param;
 182      for my $paramname ($q->param) {
 183           if ($single{$paramname}) {
 184                $param{$paramname} = $q->param($paramname);
 185           }
 186           else {
 187                $param{$paramname} = [$q->param($paramname)];
 188           }
 189      }
 190      for my $default (keys %{$options{default}}) {
 191           if (not exists $param{$default}) {
 192                # We'll clone the reference here to avoid surprises later.
 193                $param{$default} = ref($options{default}{$default})?
 194                     dclone($options{default}{$default}):$options{default}{$default};
 195           }
 196      }
 197      return %param;
 198 }
 199
 200
 201 sub quitcgi {
 202     my $msg = shift;
 203     print "Content-Type: text/html\n\n";
 204     print "<HTML><HEAD><TITLE>Error</TITLE></HEAD><BODY>\n";
 205     print "An error occurred. Dammit.\n";
 206     print "Error was: $msg.\n";
 207     print "</BODY></HTML>\n";
 208     exit 0;
 209 }
 210
 211
 212 my %common_bugusertags;
 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 # Split a package string from the status file into a list of package names.
 342 sub splitpackages {
 343     my $pkgs = shift;
 344     return unless defined $pkgs;
 345     return map lc, split /[ \t?,()]+/, $pkgs;
 346 }
 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 my $_maintainer;
 467 my $_maintainer_rev;
 468 sub getmaintainers {
 469     return $_maintainer if $_maintainer;
 470     my %maintainer;
 471     my %maintainer_rev;
 472     for my $file (@config{qw(maintainer_file maintainer_file_override)}) {
 473          next unless defined $file;
 474          my $maintfile = new IO::File $file,'r' or
 475               &quitcgi("Unable to open $file: $!");
 476          while(<$maintfile>) {
 477               next unless m/^(\S+)\s+(\S.*\S)\s*$/;
 478               ($a,$b)=($1,$2);
 479               $a =~ y/A-Z/a-z/;
 480               $maintainer{$a}= $b;
 481               for my $maint (map {lc($_->address)} getparsedaddrs($b)) {
 482                    push @{$maintainer_rev{$maint}},$a;
 483               }
 484          }
 485          close($maintfile);
 486     }
 487     $_maintainer = \%maintainer;
 488     $_maintainer_rev = \%maintainer_rev;
 489     return $_maintainer;
 490 }
 491 sub getmaintainers_reverse{
 492      return $_maintainer_rev if $_maintainer_rev;
 493      getmaintainers();
 494      return $_maintainer_rev;
 495 }
 496
 497
 498 my $_pseudodesc;
 499 sub getpseudodesc {
 500     return $_pseudodesc if $_pseudodesc;
 501     my %pseudodesc;
 502
 503     my $pseudo = new IO::File $config{pseudo_desc_file},'r'
 504          or &quitcgi("Unable to open $config{pseudo_desc_file}: $!");
 505     while(<$pseudo>) {
 506         next unless m/^(\S+)\s+(\S.*\S)\s*$/;
 507         $pseudodesc{lc $1} = $2;
 508     }
 509     close($pseudo);
 510     $_pseudodesc = \%pseudodesc;
 511     return $_pseudodesc;
 512 }
 513
 514
 515 =head2 bug_links
 516
 517      bug_links($one_bug);
 518      bug_links($starting_bug,$stoping_bugs,);
 519
 520 Creates a set of links to bugs, starting with bug number
 521 $starting_bug, and finishing with $stoping_bug; if only one bug is
 522 passed, makes a link to only a single bug.
 523
 524 The content of the link is the bug number.
 525
 526 XXX Use L<Params::Validate>; we want to be able to support query
 527 arguments here too.
 528
 529 =cut
 530
 531 sub bug_links{
 532      my ($start,$stop,$query_arguments) = @_;
 533      $stop = $stop || $start;
 534      $query_arguments ||= '';
 535      my @output;
 536      for my $bug ($start..$stop) {
 537           push @output,'<a href="'.bug_url($bug,'').qq(">$bug</a>);
 538      }
 539      return join(', ',@output);
 540 }
 541
 542 =head2 bug_linklist
 543
 544      bug_linklist($separator,$class,@bugs)
 545
 546 Creates a set of links to C<@bugs> separated by C<$separator> with
 547 link class C<$class>.
 548
 549 XXX Use L<Params::Validate>; we want to be able to support query
 550 arguments here too; we should be able to combine bug_links and this
 551 function into one. [Hell, bug_url should be one function with this one
 552 too.]
 553
 554 =cut
 555
 556
 557 sub bug_linklist{
 558      my ($sep,$class,@bugs) = @_;
 559      if (length $class) {
 560           $class = qq(class="$class" );
 561      }
 562      return join($sep,map{qq(<a ${class}href=").
 563                                bug_url($_).qq(">#$_</a>)
 564                           } @bugs);
 565 }
 566
 567
 568
 569
 570 1;
 571
 572
 573 __END__
 574
 575
 576
 577
 578
 579