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