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