Debbugs/CGI.pm

   1 # This module is part of debbugs, and is released
   2 # under the terms of the GPL version 2, or any later
   3 # version at your option.
   4 # See the file README and COPYING for more information.
   5 #
   6 # [Other people have contributed to this file; their copyrights should
   7 # go here too.]
   8 # Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
   9
  10 package Debbugs::CGI;
  11
  12 =head1 NAME
  13
  14 Debbugs::CGI -- General routines for the cgi scripts
  15
  16 =head1 SYNOPSIS
  17
  18 use Debbugs::CGI qw(:url :html);
  19
  20 html_escape(bug_url($ref,mbox=>'yes',mboxstatus=>'yes'));
  21
  22 =head1 DESCRIPTION
  23
  24 This module is a replacement for parts of common.pl; subroutines in
  25 common.pl will be gradually phased out and replaced with equivalent
  26 (or better) functionality here.
  27
  28 =head1 BUGS
  29
  30 None known.
  31
  32 =cut
  33
  34 use warnings;
  35 use strict;
  36 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
  37 use base qw(Exporter);
  38 use Debbugs::URI;
  39 use HTML::Entities;
  40 use Debbugs::Common qw(getparsedaddrs);
  41 use Params::Validate qw(validate_with :types);
  42 use Debbugs::Config qw(:config);
  43 use Debbugs::Status qw(splitpackages isstrongseverity);
  44 use Mail::Address;
  45 use POSIX qw(ceil);
  46 use Storable qw(dclone);
  47
  48 use Debbugs::Text qw(fill_in_template);
  49
  50 our %URL_PARAMS = ();
  51
  52
  53 BEGIN{
  54      ($VERSION) = q$Revision: 1.3 $ =~ /^Revision:\s+([^\s+])/;
  55      $DEBUG = 0 unless defined $DEBUG;
  56
  57      @EXPORT = ();
  58      %EXPORT_TAGS = (url    => [qw(bug_url bug_links bug_linklist maybelink),
  59                                 qw(set_url_params pkg_url version_url),
  60                                 qw(submitterurl mainturl munge_url)
  61                                ],
  62                      html   => [qw(html_escape htmlize_bugs htmlize_packagelinks),
  63                                 qw(maybelink htmlize_addresslinks htmlize_maintlinks),
  64                                ],
  65                      util   => [qw(cgi_parameters quitcgi),
  66                                ],
  67                      misc   => [qw(maint_decode)],
  68                      #status => [qw(getbugstatus)],
  69                     );
  70      @EXPORT_OK = ();
  71      Exporter::export_ok_tags(qw(url html util misc));
  72      $EXPORT_TAGS{all} = [@EXPORT_OK];
  73 }
  74
  75
  76
  77 =head2 set_url_params
  78
  79      set_url_params($uri);
  80
  81
  82 Sets the url params which will be used to generate urls.
  83
  84 =cut
  85
  86 sub set_url_params{
  87      if (@_ > 1) {
  88           %URL_PARAMS = @_;
  89      }
  90      else {
  91           my $url = Debbugs::URI->new($_[0]||'');
  92           %URL_PARAMS = %{$url->query_form_hash};
  93      }
  94 }
  95
  96
  97 =head2 bug_url
  98
  99      bug_url($ref,mbox=>'yes',mboxstat=>'yes');
 100
 101 Constructs urls which point to a specific
 102
 103 XXX use Params::Validate
 104
 105 =cut
 106
 107 sub bug_url{
 108      my $ref = shift;
 109      my %params;
 110      if (@_ % 2) {
 111           shift;
 112           %params = (%URL_PARAMS,@_);
 113      }
 114      else {
 115           %params = @_;
 116      }
 117      return munge_url('bugreport.cgi?',%params,bug=>$ref);
 118 }
 119
 120 sub pkg_url{
 121      my %params;
 122      if (@_ % 2) {
 123           shift;
 124           %params = (%URL_PARAMS,@_);
 125      }
 126      else {
 127           %params = @_;
 128      }
 129      return munge_url('pkgreport.cgi?',%params);
 130 }
 131
 132 =head2 munge_url
 133
 134      my $url = munge_url($url,%params_to_munge);
 135
 136 Munges a url, replacing parameters with %params_to_munge as appropriate.
 137
 138 =cut
 139
 140 sub munge_url {
 141      my $url = shift;
 142      my %params = @_;
 143      my $new_url = Debbugs::URI->new($url);
 144      my @old_param = $new_url->query_form();
 145      my @new_param;
 146      while (my ($key,$value) = splice @old_param,0,2) {
 147           push @new_param,($key,$value) unless exists $params{$key};
 148      }
 149      $new_url->query_form(@new_param,%params);
 150      return $new_url->as_string;
 151 }
 152
 153
 154 =head2 version_url
 155
 156      version_url(package => $package,found => $found,fixed => $fixed)
 157
 158 Creates a link to the version cgi script
 159
 160 =over
 161
 162 =item package -- source package whose graph to display
 163
 164 =item found -- arrayref of found versions
 165
 166 =item fixed -- arrayref of fixed versions
 167
 168 =item width -- optional width of graph
 169
 170 =item height -- optional height of graph
 171
 172 =item info -- display html info surrounding graph; defaults to 1 if
 173 width and height are not passed.
 174
 175 =item collapse -- whether to collapse the graph; defaults to 1 if
 176 width and height are passed.
 177
 178 =back
 179
 180 =cut
 181
 182 sub version_url{
 183      my %params = validate_with(params => \@_,
 184                                 spec   => {package => {type => SCALAR,
 185                                                       },
 186                                            found   => {type => ARRAYREF,
 187                                                        default => [],
 188                                                       },
 189                                            fixed   => {type => ARRAYREF,
 190                                                        default => [],
 191                                                       },
 192                                            width   => {type => SCALAR,
 193                                                        optional => 1,
 194                                                       },
 195                                            height  => {type => SCALAR,
 196                                                        optional => 1,
 197                                                       },
 198                                            absolute => {type => BOOLEAN,
 199                                                         default => 0,
 200                                                        },
 201                                            collapse => {type => BOOLEAN,
 202                                                         default => 1,
 203                                                        },
 204                                            info     => {type => BOOLEAN,
 205                                                         optional => 1,
 206                                                        },
 207                                           }
 208                                );
 209      if (not defined $params{width} and not defined $params{height}) {
 210           $params{info} = 1 if not exists $params{info};
 211      }
 212      my $url = Debbugs::URI->new('version.cgi?');
 213      $url->query_form(%params);
 214      return $url->as_string;
 215 }
 216
 217 =head2 html_escape
 218
 219      html_escape($string)
 220
 221 Escapes html entities by calling HTML::Entities::encode_entities;
 222
 223 =cut
 224
 225 sub html_escape{
 226      my ($string) = @_;
 227
 228      return HTML::Entities::encode_entities($string,q(<>&"'));
 229 }
 230
 231 =head2 cgi_parameters
 232
 233      cgi_parameters
 234
 235 Returns all of the cgi_parameters from a CGI script using CGI::Simple
 236
 237 =cut
 238
 239 sub cgi_parameters {
 240      my %options = validate_with(params => \@_,
 241                                  spec   => {query   => {type => OBJECT,
 242                                                         can  => 'param',
 243                                                        },
 244                                             single  => {type => ARRAYREF,
 245                                                         default => [],
 246                                                        },
 247                                             default => {type => HASHREF,
 248                                                         default => {},
 249                                                        },
 250                                            },
 251                                 );
 252      my $q = $options{query};
 253      my %single;
 254      @single{@{$options{single}}} = (1) x @{$options{single}};
 255      my %param;
 256      for my $paramname ($q->param) {
 257           if ($single{$paramname}) {
 258                $param{$paramname} = $q->param($paramname);
 259           }
 260           else {
 261                $param{$paramname} = [$q->param($paramname)];
 262           }
 263      }
 264      for my $default (keys %{$options{default}}) {
 265           if (not exists $param{$default}) {
 266                # We'll clone the reference here to avoid surprises later.
 267                $param{$default} = ref($options{default}{$default})?
 268                     dclone($options{default}{$default}):$options{default}{$default};
 269           }
 270      }
 271      return %param;
 272 }
 273
 274
 275 sub quitcgi {
 276     my $msg = shift;
 277     print "Content-Type: text/html\n\n";
 278     print fill_in_template(template=>'cgi/quit',
 279                            variables => {msg => $msg}
 280                           );
 281     exit 0;
 282 }
 283
 284
 285 =head HTML
 286
 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 #     htmlize_bugs(bugs=>[@bugs]);
 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 =head2 htmlize_packagelinks
 411
 412      htmlize_packagelinks
 413
 414 Given a scalar containing a list of packages separated by something
 415 that L<Debbugs::CGI/splitpackages> can separate, returns a
 416 formatted set of links to packages.
 417
 418 =cut
 419
 420 sub htmlize_packagelinks {
 421     my ($pkgs,$strong) = @_;
 422     return unless defined $pkgs and $pkgs ne '';
 423     my @pkglist = splitpackages($pkgs);
 424
 425     $strong = 0;
 426     my $openstrong  = $strong ? '<strong>' : '';
 427     my $closestrong = $strong ? '</strong>' : '';
 428
 429     return 'Package' . (@pkglist > 1 ? 's' : '') . ': ' .
 430            join(', ',
 431                 map {
 432                     '<a class="submitter" href="' . pkg_url(pkg=>$_||'') . '">' .
 433                     $openstrong . html_escape($_) . $closestrong . '</a>'
 434                 } @pkglist
 435            );
 436 }
 437
 438
 439 =head2 maybelink
 440
 441      maybelink($in);
 442      maybelink('http://foobarbaz,http://bleh',qr/[, ]+/);
 443      maybelink('http://foobarbaz,http://bleh',qr/[, ]+/,', ');
 444
 445
 446 In the first form, links the link if it looks like a link. In the
 447 second form, first splits based on the regex, then reassembles the
 448 link, linking things that look like links. In the third form, rejoins
 449 the split links with commas and spaces.
 450
 451 =cut
 452
 453 sub maybelink {
 454     my ($links,$regex,$join) = @_;
 455     $join = ' ' if not defined $join;
 456     my @return;
 457     my @segments;
 458     if (defined $regex) {
 459          @segments = split $regex, $links;
 460     }
 461     else {
 462          @segments = ($links);
 463     }
 464     for my $in (@segments) {
 465          if ($in =~ /^[a-zA-Z0-9+.-]+:/) { # RFC 1738 scheme
 466               push @return, qq{<a href="$in">} . html_escape($in) . '</a>';
 467          } else {
 468               push @return, html_escape($in);
 469          }
 470     }
 471     return @return?join($join,@return):'';
 472 }
 473
 474
 475 =head2 htmlize_addresslinks
 476
 477      htmlize_addresslinks($prefixfunc,$urlfunc,$addresses,$class);
 478
 479
 480 Generate a comma-separated list of HTML links to each address given in
 481 $addresses, which should be a comma-separated list of RFC822
 482 addresses. $urlfunc should be a reference to a function like mainturl
 483 or submitterurl which returns the URL for each individual address.
 484
 485
 486 =cut
 487
 488 sub htmlize_addresslinks {
 489      my ($prefixfunc, $urlfunc, $addresses,$class) = @_;
 490      $class = defined $class?qq(class="$class" ):'';
 491      if (defined $addresses and $addresses ne '') {
 492           my @addrs = getparsedaddrs($addresses);
 493           my $prefix = (ref $prefixfunc) ?
 494                $prefixfunc->(scalar @addrs):$prefixfunc;
 495           return $prefix .
 496                join(', ', map
 497                     { sprintf qq(<a ${class}).
 498                            'href="%s">%s</a>',
 499                                 $urlfunc->($_->address),
 500                                      html_escape($_->format) ||
 501                                           '(unknown)'
 502                                      } @addrs
 503                    );
 504      }
 505      else {
 506           my $prefix = (ref $prefixfunc) ?
 507                $prefixfunc->(1) : $prefixfunc;
 508           return sprintf '%s<a '.$class.'href="%s">(unknown)</a>',
 509                $prefix, $urlfunc->('');
 510      }
 511 }
 512
 513 sub emailfromrfc822{
 514      my $addr = getparsedaddrs($_[0] || "");
 515      $addr = defined $addr?$addr->address:'';
 516      return $addr;
 517 }
 518
 519 sub mainturl { pkg_url(maint => emailfromrfc822($_[0])); }
 520 sub submitterurl { pkg_url(submitter => emailfromrfc822($_[0])); }
 521 sub htmlize_maintlinks {
 522     my ($prefixfunc, $maints) = @_;
 523     return htmlize_addresslinks($prefixfunc, \&mainturl, $maints);
 524 }
 525
 526
 527 our $_maintainer;
 528 our $_maintainer_rev;
 529
 530 =head2 bug_links
 531
 532      bug_links($one_bug);
 533      bug_links($starting_bug,$stoping_bugs,);
 534
 535 Creates a set of links to bugs, starting with bug number
 536 $starting_bug, and finishing with $stoping_bug; if only one bug is
 537 passed, makes a link to only a single bug.
 538
 539 The content of the link is the bug number.
 540
 541 XXX Use L<Params::Validate>; we want to be able to support query
 542 arguments here too.
 543
 544 =cut
 545
 546 sub bug_links{
 547      my ($start,$stop,$query_arguments) = @_;
 548      $stop = $stop || $start;
 549      $query_arguments ||= '';
 550      my @output;
 551      for my $bug ($start..$stop) {
 552           push @output,'<a href="'.bug_url($bug,'').qq(">$bug</a>);
 553      }
 554      return join(', ',@output);
 555 }
 556
 557 =head2 bug_linklist
 558
 559      bug_linklist($separator,$class,@bugs)
 560
 561 Creates a set of links to C<@bugs> separated by C<$separator> with
 562 link class C<$class>.
 563
 564 XXX Use L<Params::Validate>; we want to be able to support query
 565 arguments here too; we should be able to combine bug_links and this
 566 function into one. [Hell, bug_url should be one function with this one
 567 too.]
 568
 569 =cut
 570
 571
 572 sub bug_linklist{
 573      my ($sep,$class,@bugs) = @_;
 574      if (length $class) {
 575           $class = qq(class="$class" );
 576      }
 577      return join($sep,map{qq(<a ${class}href=").
 578                                bug_url($_).qq(">#$_</a>)
 579                           } @bugs);
 580 }
 581
 582
 583 =head1 misc
 584
 585 =cut
 586
 587 =head2 maint_decode
 588
 589      maint_decode
 590
 591 Decodes the funky maintainer encoding.
 592
 593 Don't ask me what in the world it does.
 594
 595 =cut
 596
 597 sub maint_decode {
 598      my @input = @_;
 599      return () unless @input;
 600      my @output;
 601      for my $input (@input) {
 602           my $decoded = $input;
 603           $decoded =~ s/-([^_]+)/-$1_-/g;
 604           $decoded =~ s/_/-20_/g;
 605           $decoded =~ s/^,(.*),(.*),([^,]+)$/$1-40_$2-20_-28_$3-29_/;
 606           $decoded =~ s/^([^,]+),(.*),(.*),/$1-20_-3c_$2-40_$3-3e_/;
 607           $decoded =~ s/\./-2e_/g;
 608           $decoded =~ s/-([0-9a-f]{2})_/pack('H*',$1)/ge;
 609           push @output,$decoded;
 610      }
 611      wantarray ? @output : $output[0];
 612 }
 613
 614
 615 1;
 616
 617
 618 __END__
 619
 620
 621
 622
 623
 624