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