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();
  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                                ],
  50                      html   => [qw(html_escape htmlize_bugs htmlize_packagelinks),
  51                                 qw(maybelink htmlize_addresslinks),
  52                                ],
  53                      util   => [qw(getparsedaddrs cgi_parameters)]
  54                      #status => [qw(getbugstatus)],
  55                     );
  56      @EXPORT_OK = ();
  57      Exporter::export_ok_tags(qw(url html util));
  58      $EXPORT_TAGS{all} = [@EXPORT_OK];
  59 }
  60
  61
  62
  63 =head2 set_url_params
  64
  65      set_url_params($uri);
  66
  67
  68 Sets the url params which will be used to generate urls.
  69
  70 =cut
  71
  72 sub set_url_params{
  73      if (@_ > 1) {
  74           %URL_PARAMS = @_;
  75      }
  76      else {
  77           my $url = Debbugs::URI->new($_[0]||'');
  78           %URL_PARAMS = %{$url->query_form_hash};
  79      }
  80 }
  81
  82
  83 =head2 bug_url
  84
  85      bug_url($ref,mbox=>'yes',mboxstat=>'yes');
  86
  87 Constructs urls which point to a specific
  88
  89 XXX use Params::Validate
  90
  91 =cut
  92
  93 sub bug_url{
  94      my $ref = shift;
  95      my %params;
  96      if (@_ % 2) {
  97           shift;
  98           %params = (%URL_PARAMS,@_);
  99      }
 100      else {
 101           %params = @_;
 102      }
 103      my $url = Debbugs::URI->new('bugreport.cgi?');
 104      $url->query_form(bug=>$ref,%params);
 105      return $url->as_string;
 106 }
 107
 108 sub pkg_url{
 109      my %params;
 110      if (@_ % 2) {
 111           shift;
 112           %params = (%URL_PARAMS,@_);
 113      }
 114      else {
 115           %params = @_;
 116      }
 117      my $url = Debbugs::URI->new('pkgreport.cgi?');
 118      $url->query_form(%params);
 119      return $url->as_string;
 120 }
 121
 122 =head2 version_url
 123
 124      version_url($package,$found,$fixed)
 125
 126 Creates a link to the version cgi script
 127
 128 =cut
 129
 130 sub version_url{
 131      my ($package,$found,$fixed) = @_;
 132      my $url = Debbugs::URI->new('version.cgi?');
 133      $url->query_form(package => $package,
 134                       found   => $found,
 135                       fixed   => $fixed,
 136                      );
 137      return $url->as_string;
 138 }
 139
 140 =head2 html_escape
 141
 142      html_escape($string)
 143
 144 Escapes html entities by calling HTML::Entities::encode_entities;
 145
 146 =cut
 147
 148 sub html_escape{
 149      my ($string) = @_;
 150
 151      return HTML::Entities::encode_entities($string)
 152 }
 153
 154 =head2 cgi_parameters
 155
 156      cgi_parameters
 157
 158 Returns all of the cgi_parameters from a CGI script using CGI::Simple
 159
 160 =cut
 161
 162 sub cgi_parameters {
 163      my %options = validate_with(params => \@_,
 164                                  spec   => {query   => {type => OBJECT,
 165                                                         can  => 'param',
 166                                                        },
 167                                             single  => {type => ARRAYREF,
 168                                                         default => [],
 169                                                        },
 170                                             default => {type => HASHREF,
 171                                                         default => {},
 172                                                        },
 173                                            },
 174                                 );
 175      my $q = $options{query};
 176      my %single;
 177      @single{@{$options{single}}} = (1) x @{$options{single}};
 178      my %param;
 179      for my $paramname ($q->param) {
 180           if ($single{$paramname}) {
 181                $param{$paramname} = $q->param($paramname);
 182           }
 183           else {
 184                $param{$paramname} = [$q->param($paramname)];
 185           }
 186      }
 187      for my $default (keys %{$options{default}}) {
 188           if (not exists $param{$default}) {
 189                # We'll clone the reference here to avoid surprises later.
 190                $param{$default} = ref($options{default}{$default})?
 191                     dclone($options{default}{$default}):$options{default}{$default};
 192           }
 193      }
 194      return %param;
 195 }
 196
 197
 198
 199 my %common_bugusertags;
 200
 201 # =head2 get_bug_status
 202 #
 203 #      my $status = getbugstatus($bug_num)
 204 #
 205 #      my $status = getbugstatus($bug_num,$bug_index)
 206 #
 207 #
 208 # =cut
 209 #
 210 # sub get_bug_status {
 211 #     my ($bugnum,$bugidx) = @_;
 212 #
 213 #     my %status;
 214 #
 215 #     if (defined $bugidx and exists $bugidx->{$bugnum}) {
 216 #       %status = %{ $bugidx->{$bugnum} };
 217 #       $status{pending} = $status{ status };
 218 #       $status{id} = $bugnum;
 219 #       return \%status;
 220 #     }
 221 #
 222 #     my $location = getbuglocation($bugnum, 'summary');
 223 #     return {} if not length $location;
 224 #     %status = %{ readbug( $bugnum, $location ) };
 225 #     $status{id} = $bugnum;
 226 #
 227 #
 228 #     if (defined $common_bugusertags{$bugnum}) {
 229 #         $status{keywords} = "" unless defined $status{keywords};
 230 #         $status{keywords} .= " " unless $status{keywords} eq "";
 231 #         $status{keywords} .= join(" ", @{$common_bugusertags{$bugnum}});
 232 #     }
 233 #     $status{tags} = $status{keywords};
 234 #     my %tags = map { $_ => 1 } split ' ', $status{tags};
 235 #
 236 #     $status{"package"} =~ s/\s*$//;
 237 #     $status{"package"} = 'unknown' if ($status{"package"} eq '');
 238 #     $status{"severity"} = 'normal' if ($status{"severity"} eq '');
 239 #
 240 #     $status{"pending"} = 'pending';
 241 #     $status{"pending"} = 'forwarded'      if (length($status{"forwarded"}));
 242 #     $status{"pending"} = 'pending-fixed'    if ($tags{pending});
 243 #     $status{"pending"} = 'fixed'          if ($tags{fixed});
 244 #
 245 #     my @versions;
 246 #     if (defined $common_version) {
 247 #         @versions = ($common_version);
 248 #     } elsif (defined $common_dist) {
 249 #         @versions = getversions($status{package}, $common_dist, $common_arch);
 250 #     }
 251 #
 252 #     # TODO: This should probably be handled further out for efficiency and
 253 #     # for more ease of distinguishing between pkg= and src= queries.
 254 #     my @sourceversions = makesourceversions($status{package}, $common_arch,
 255 #                                             @versions);
 256 #
 257 #     if (@sourceversions) {
 258 #         # Resolve bugginess states (we might be looking at multiple
 259 #         # architectures, say). Found wins, then fixed, then absent.
 260 #         my $maxbuggy = 'absent';
 261 #         for my $version (@sourceversions) {
 262 #             my $buggy = buggyversion($bugnum, $version, \%status);
 263 #             if ($buggy eq 'found') {
 264 #                 $maxbuggy = 'found';
 265 #                 last;
 266 #             } elsif ($buggy eq 'fixed' and $maxbuggy ne 'found') {
 267 #                 $maxbuggy = 'fixed';
 268 #             }
 269 #         }
 270 #         if ($maxbuggy eq 'absent') {
 271 #             $status{"pending"} = 'absent';
 272 #         } elsif ($maxbuggy eq 'fixed') {
 273 #             $status{"pending"} = 'done';
 274 #         }
 275 #     }
 276 #
 277 #     if (length($status{done}) and
 278 #             (not @sourceversions or not @{$status{fixed_versions}})) {
 279 #         $status{"pending"} = 'done';
 280 #     }
 281 #
 282 #     return \%status;
 283 # }
 284
 285
 286 #     htmlize_bugs(bugs=>[@bugs]);
 287 =head2 htmlize_bugs
 288
 289      htmlize_bugs({bug=>1,status=>\%status,extravars=>\%extra},{bug=>...}});
 290
 291 Turns a list of bugs into an html snippit of the bugs.
 292
 293 =cut
 294
 295 sub htmlize_bugs{
 296      my @bugs = @_;
 297      my @html;
 298
 299      for my $bug (@bugs) {
 300           my $html = sprintf "<li><a href=\"%s\">#%d: %s</a>\n<br>",
 301                bug_url($bug->{bug}), $bug->{bug}, html_escape($bug->{status}{subject});
 302           $html .= htmlize_bugstatus($bug->{status}) . "\n";
 303      }
 304      return @html;
 305 }
 306
 307
 308 sub htmlize_bugstatus {
 309      my %status = %{$_[0]};
 310
 311      my $result = "";
 312
 313      my $showseverity;
 314      if  ($status{severity} eq $config{default_severity}) {
 315           $showseverity = '';
 316      } elsif (isstrongseverity($status{severity})) {
 317           $showseverity = "Severity: <em class=\"severity\">$status{severity}</em>;\n";
 318      } else {
 319           $showseverity = "Severity: <em>$status{severity}</em>;\n";
 320      }
 321
 322      $result .= htmlize_packagelinks($status{"package"}, 1);
 323
 324      my $showversions = '';
 325      if (@{$status{found_versions}}) {
 326           my @found = @{$status{found_versions}};
 327           local $_;
 328           s{/}{ } foreach @found;
 329           $showversions .= join ', ', map html_escape($_), @found;
 330      }
 331      if (@{$status{fixed_versions}}) {
 332           $showversions .= '; ' if length $showversions;
 333           $showversions .= '<strong>fixed</strong>: ';
 334           my @fixed = @{$status{fixed_versions}};
 335           $showversions .= join ', ', map {s#/##; html_escape($_)} @fixed;
 336      }
 337      $result .= " ($showversions)" if length $showversions;
 338      $result .= ";\n";
 339
 340      $result .= $showseverity;
 341      $result .= htmlize_addresslinks("Reported by: ", \&submitterurl,
 342                                 $status{originator});
 343      $result .= ";\nOwned by: " . html_escape($status{owner})
 344           if length $status{owner};
 345      $result .= ";\nTags: <strong>"
 346           . html_escape(join(", ", sort(split(/\s+/, $status{tags}))))
 347                . "</strong>"
 348                     if (length($status{tags}));
 349
 350      $result .= ";\nMerged with ".
 351           bug_linklist(', ',
 352                        'submitter',
 353                        split(/ /,$status{mergedwith}))
 354                if length $status{mergedwith};
 355      $result .= ";\nBlocked by ".
 356           bug_linklist(", ",
 357                        'submitter',
 358                        split(/ /,$status{blockedby}))
 359                if length $status{blockedby};
 360      $result .= ";\nBlocks ".
 361           bug_linklist(", ",
 362                        'submitter',
 363                        split(/ /,$status{blocks})
 364                       )
 365                if length $status{blocks};
 366
 367      my $days = 0;
 368      if (length($status{done})) {
 369           $result .= "<br><strong>Done:</strong> " . html_escape($status{done});
 370           $days = ceil($debbugs::gRemoveAge - -M buglog($status{id}));
 371           if ($days >= 0) {
 372                $result .= ";\n<strong>Will be archived" . ( $days == 0 ? " today" : $days == 1 ? " in $days day" : " in $days days" ) . "</strong>";
 373           } else {
 374                $result .= ";\n<strong>Archived</strong>";
 375           }
 376      }
 377      else {
 378           if (length($status{forwarded})) {
 379                $result .= ";\n<strong>Forwarded</strong> to "
 380                     . maybelink($status{forwarded});
 381           }
 382           my $daysold = int((time - $status{date}) / 86400);   # seconds to days
 383           if ($daysold >= 7) {
 384                my $font = "";
 385                my $efont = "";
 386                $font = "em" if ($daysold > 30);
 387                $font = "strong" if ($daysold > 60);
 388                $efont = "</$font>" if ($font);
 389                $font = "<$font>" if ($font);
 390
 391                my $yearsold = int($daysold / 365);
 392                $daysold -= $yearsold * 365;
 393
 394                $result .= ";\n $font";
 395                my @age;
 396                push @age, "1 year" if ($yearsold == 1);
 397                push @age, "$yearsold years" if ($yearsold > 1);
 398                push @age, "1 day" if ($daysold == 1);
 399                push @age, "$daysold days" if ($daysold > 1);
 400                $result .= join(" and ", @age);
 401                $result .= " old$efont";
 402         }
 403     }
 404
 405     $result .= ".";
 406
 407     return $result;
 408 }
 409
 410 # Split a package string from the status file into a list of package names.
 411 sub splitpackages {
 412     my $pkgs = shift;
 413     return unless defined $pkgs;
 414     return map lc, split /[ \t?,()]+/, $pkgs;
 415 }
 416
 417
 418 =head2 htmlize_packagelinks
 419
 420      htmlize_packagelinks
 421
 422 Given a scalar containing a list of packages separated by something
 423 that L<Debbugs::CGI/splitpackages> can separate, returns a
 424 formatted set of links to packages.
 425
 426 =cut
 427
 428 sub htmlize_packagelinks {
 429     my ($pkgs,$strong) = @_;
 430     return unless defined $pkgs and $pkgs ne '';
 431     my @pkglist = splitpackages($pkgs);
 432
 433     $strong = 0;
 434     my $openstrong  = $strong ? '<strong>' : '';
 435     my $closestrong = $strong ? '</strong>' : '';
 436
 437     return 'Package' . (@pkglist > 1 ? 's' : '') . ': ' .
 438            join(', ',
 439                 map {
 440                     '<a class="submitter" href="' . pkg_url(pkg=>$_||'') . '">' .
 441                     $openstrong . html_escape($_) . $closestrong . '</a>'
 442                 } @pkglist
 443            );
 444 }
 445
 446
 447 =head2 maybelink
 448
 449      maybelink($in);
 450      maybelink('http://foobarbaz,http://bleh',qr/[, ]+/);
 451      maybelink('http://foobarbaz,http://bleh',qr/[, ]+/,', ');
 452
 453
 454 In the first form, links the link if it looks like a link. In the
 455 second form, first splits based on the regex, then reassembles the
 456 link, linking things that look like links. In the third form, rejoins
 457 the split links with commas and spaces.
 458
 459 =cut
 460
 461 sub maybelink {
 462     my ($links,$regex,$join) = @_;
 463     $join = ' ' if not defined $join;
 464     my @return;
 465     my @segments;
 466     if (defined $regex) {
 467          @segments = split $regex, $links;
 468     }
 469     else {
 470          @segments = ($links);
 471     }
 472     for my $in (@segments) {
 473          if ($in =~ /^[a-zA-Z0-9+.-]+:/) { # RFC 1738 scheme
 474               push @return, qq{<a href="$in">} . html_escape($in) . '</a>';
 475          } else {
 476               push @return, html_escape($in);
 477          }
 478     }
 479     return @return?join($join,@return):'';
 480 }
 481
 482
 483 =head2 htmlize_addresslinks
 484
 485      htmlize_addresslinks($prefixfunc,$urlfunc,$addresses,$class);
 486
 487
 488 Generate a comma-separated list of HTML links to each address given in
 489 $addresses, which should be a comma-separated list of RFC822
 490 addresses. $urlfunc should be a reference to a function like mainturl
 491 or submitterurl which returns the URL for each individual address.
 492
 493
 494 =cut
 495
 496 sub htmlize_addresslinks {
 497      my ($prefixfunc, $urlfunc, $addresses,$class) = @_;
 498      $class = defined $class?qq(class="$class" ):'';
 499      if (defined $addresses and $addresses ne '') {
 500           my @addrs = getparsedaddrs($addresses);
 501           my $prefix = (ref $prefixfunc) ?
 502                $prefixfunc->(scalar @addrs):$prefixfunc;
 503           return $prefix .
 504                join ', ', map
 505                     { sprintf qq(<a ${class}).
 506                            'href="%s">%s</a>',
 507                                 $urlfunc->($_->address),
 508                                      html_escape($_->format) ||
 509                                           '(unknown)'
 510                                      } @addrs;
 511      }
 512      else {
 513           my $prefix = (ref $prefixfunc) ?
 514                $prefixfunc->(1) : $prefixfunc;
 515           return sprintf '%s<a '.$class.'href="%s">(unknown)</a>',
 516                $prefix, $urlfunc->('');
 517      }
 518 }
 519
 520
 521
 522 my %_parsedaddrs;
 523 sub getparsedaddrs {
 524     my $addr = shift;
 525     return () unless defined $addr;
 526     return @{$_parsedaddrs{$addr}} if exists $_parsedaddrs{$addr};
 527     @{$_parsedaddrs{$addr}} = Mail::Address->parse($addr);
 528     return @{$_parsedaddrs{$addr}};
 529 }
 530
 531
 532 =head2 bug_links
 533
 534      bug_links($one_bug);
 535      bug_links($starting_bug,$stoping_bugs,);
 536
 537 Creates a set of links to bugs, starting with bug number
 538 $starting_bug, and finishing with $stoping_bug; if only one bug is
 539 passed, makes a link to only a single bug.
 540
 541 The content of the link is the bug number.
 542
 543 XXX Use L<Params::Validate>; we want to be able to support query
 544 arguments here too.
 545
 546 =cut
 547
 548 sub bug_links{
 549      my ($start,$stop,$query_arguments) = @_;
 550      $stop = $stop || $start;
 551      $query_arguments ||= '';
 552      my @output;
 553      for my $bug ($start..$stop) {
 554           push @output,'<a href="'.bug_url($bug,'').qq(">$bug</a>);
 555      }
 556      return join(', ',@output);
 557 }
 558
 559 =head2 bug_linklist
 560
 561      bug_linklist($separator,$class,@bugs)
 562
 563 Creates a set of links to C<@bugs> separated by C<$separator> with
 564 link class C<$class>.
 565
 566 XXX Use L<Params::Validate>; we want to be able to support query
 567 arguments here too; we should be able to combine bug_links and this
 568 function into one. [Hell, bug_url should be one function with this one
 569 too.]
 570
 571 =cut
 572
 573
 574 sub bug_linklist{
 575      my ($sep,$class,@bugs) = @_;
 576      if (length $class) {
 577           $class = qq(class="$class" );
 578      }
 579      return join($sep,map{qq(<a ${class}href=").
 580                                bug_url($_).qq(">#$_</a>)
 581                           } @bugs);
 582 }
 583
 584
 585
 586
 587 1;
 588
 589
 590 __END__
 591
 592
 593
 594
 595
 596