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