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 make_list);
  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 Carp;
  49
  50 use Debbugs::Text qw(fill_in_template);
  51
  52 our %URL_PARAMS = ();
  53
  54
  55 BEGIN{
  56      ($VERSION) = q$Revision: 1.3 $ =~ /^Revision:\s+([^\s+])/;
  57      $DEBUG = 0 unless defined $DEBUG;
  58
  59      @EXPORT = ();
  60      %EXPORT_TAGS = (url    => [qw(bug_url bug_links bug_linklist maybelink),
  61                                 qw(set_url_params pkg_url version_url),
  62                                 qw(submitterurl mainturl munge_url),
  63                                 qw(package_links bug_links),
  64                                ],
  65                      html   => [qw(html_escape htmlize_bugs htmlize_packagelinks),
  66                                 qw(maybelink htmlize_addresslinks htmlize_maintlinks),
  67                                ],
  68                      util   => [qw(cgi_parameters quitcgi),
  69                                ],
  70                      misc   => [qw(maint_decode)],
  71                      #status => [qw(getbugstatus)],
  72                     );
  73      @EXPORT_OK = ();
  74      Exporter::export_ok_tags(qw(url html util misc));
  75      $EXPORT_TAGS{all} = [@EXPORT_OK];
  76 }
  77
  78
  79
  80 =head2 set_url_params
  81
  82      set_url_params($uri);
  83
  84
  85 Sets the url params which will be used to generate urls.
  86
  87 =cut
  88
  89 sub set_url_params{
  90      if (@_ > 1) {
  91           %URL_PARAMS = @_;
  92      }
  93      else {
  94           my $url = Debbugs::URI->new($_[0]||'');
  95           %URL_PARAMS = %{$url->query_form_hash};
  96      }
  97 }
  98
  99
 100 =head2 bug_url
 101
 102      bug_url($ref,mbox=>'yes',mboxstat=>'yes');
 103
 104 Constructs urls which point to a specific
 105
 106 XXX use Params::Validate
 107
 108 =cut
 109
 110 sub bug_url{
 111      my $ref = shift;
 112      my %params;
 113      if (@_ % 2) {
 114           shift;
 115           %params = (%URL_PARAMS,@_);
 116      }
 117      else {
 118           %params = @_;
 119      }
 120      return munge_url('bugreport.cgi?',%params,bug=>$ref);
 121 }
 122
 123 sub pkg_url{
 124      my %params;
 125      if (@_ % 2) {
 126           shift;
 127           %params = (%URL_PARAMS,@_);
 128      }
 129      else {
 130           %params = @_;
 131      }
 132      return munge_url('pkgreport.cgi?',%params);
 133 }
 134
 135 =head2 munge_url
 136
 137      my $url = munge_url($url,%params_to_munge);
 138
 139 Munges a url, replacing parameters with %params_to_munge as appropriate.
 140
 141 =cut
 142
 143 sub munge_url {
 144      my $url = shift;
 145      my %params = @_;
 146      my $new_url = Debbugs::URI->new($url);
 147      my @old_param = $new_url->query_form();
 148      my @new_param;
 149      while (my ($key,$value) = splice @old_param,0,2) {
 150           push @new_param,($key,$value) unless exists $params{$key};
 151      }
 152      $new_url->query_form(@new_param,%params);
 153      return $new_url->as_string;
 154 }
 155
 156
 157 =head2 version_url
 158
 159      version_url(package => $package,found => $found,fixed => $fixed)
 160
 161 Creates a link to the version cgi script
 162
 163 =over
 164
 165 =item package -- source package whose graph to display
 166
 167 =item found -- arrayref of found versions
 168
 169 =item fixed -- arrayref of fixed versions
 170
 171 =item width -- optional width of graph
 172
 173 =item height -- optional height of graph
 174
 175 =item info -- display html info surrounding graph; defaults to 1 if
 176 width and height are not passed.
 177
 178 =item collapse -- whether to collapse the graph; defaults to 1 if
 179 width and height are passed.
 180
 181 =back
 182
 183 =cut
 184
 185 sub version_url{
 186      my %params = validate_with(params => \@_,
 187                                 spec   => {package => {type => SCALAR,
 188                                                       },
 189                                            found   => {type => ARRAYREF,
 190                                                        default => [],
 191                                                       },
 192                                            fixed   => {type => ARRAYREF,
 193                                                        default => [],
 194                                                       },
 195                                            width   => {type => SCALAR,
 196                                                        optional => 1,
 197                                                       },
 198                                            height  => {type => SCALAR,
 199                                                        optional => 1,
 200                                                       },
 201                                            absolute => {type => BOOLEAN,
 202                                                         default => 0,
 203                                                        },
 204                                            collapse => {type => BOOLEAN,
 205                                                         default => 1,
 206                                                        },
 207                                            info     => {type => BOOLEAN,
 208                                                         optional => 1,
 209                                                        },
 210                                           }
 211                                );
 212      if (not defined $params{width} and not defined $params{height}) {
 213           $params{info} = 1 if not exists $params{info};
 214      }
 215      my $url = Debbugs::URI->new('version.cgi?');
 216      $url->query_form(%params);
 217      return $url->as_string;
 218 }
 219
 220 =head2 html_escape
 221
 222      html_escape($string)
 223
 224 Escapes html entities by calling HTML::Entities::encode_entities;
 225
 226 =cut
 227
 228 sub html_escape{
 229      my ($string) = @_;
 230
 231      return HTML::Entities::encode_entities($string,q(<>&"'));
 232 }
 233
 234 =head2 cgi_parameters
 235
 236      cgi_parameters
 237
 238 Returns all of the cgi_parameters from a CGI script using CGI::Simple
 239
 240 =cut
 241
 242 sub cgi_parameters {
 243      my %options = validate_with(params => \@_,
 244                                  spec   => {query   => {type => OBJECT,
 245                                                         can  => 'param',
 246                                                        },
 247                                             single  => {type => ARRAYREF,
 248                                                         default => [],
 249                                                        },
 250                                             default => {type => HASHREF,
 251                                                         default => {},
 252                                                        },
 253                                            },
 254                                 );
 255      my $q = $options{query};
 256      my %single;
 257      @single{@{$options{single}}} = (1) x @{$options{single}};
 258      my %param;
 259      for my $paramname ($q->param) {
 260           if ($single{$paramname}) {
 261                $param{$paramname} = $q->param($paramname);
 262           }
 263           else {
 264                $param{$paramname} = [$q->param($paramname)];
 265           }
 266      }
 267      for my $default (keys %{$options{default}}) {
 268           if (not exists $param{$default}) {
 269                # We'll clone the reference here to avoid surprises later.
 270                $param{$default} = ref($options{default}{$default})?
 271                     dclone($options{default}{$default}):$options{default}{$default};
 272           }
 273      }
 274      return %param;
 275 }
 276
 277
 278 sub quitcgi {
 279     my $msg = shift;
 280     print "Content-Type: text/html\n\n";
 281     print fill_in_template(template=>'cgi/quit',
 282                            variables => {msg => $msg}
 283                           );
 284     exit 0;
 285 }
 286
 287
 288 =head HTML
 289
 290 =head2 htmlize_packagelinks
 291
 292      htmlize_packagelinks
 293
 294 Given a scalar containing a list of packages separated by something
 295 that L<Debbugs::CGI/splitpackages> can separate, returns a
 296 formatted set of links to packages.
 297
 298 =cut
 299
 300 sub htmlize_packagelinks {
 301     my ($pkgs) = @_;
 302     return '' unless defined $pkgs and $pkgs ne '';
 303     my @pkglist = splitpackages($pkgs);
 304
 305     carp "htmlize_packagelinks is deprecated";
 306
 307     return 'Package' . (@pkglist > 1 ? 's' : '') . ': ' .
 308            join(', ',
 309                 package_links(package =>\@pkglist,
 310                               class   => 'submitter'
 311                              )
 312            );
 313 }
 314
 315 =head2 package_links
 316
 317      join(', ', package_links(packages => \@packages))
 318
 319 Given a list of packages, return a list of html which links to the package
 320
 321 =over
 322
 323 =item package -- arrayref or scalar of package(s)
 324
 325 =item submitter -- arrayref or scalar of submitter(s)
 326
 327 =item source -- arrayref or scalar of source(s)
 328
 329 =item maintainer -- arrayref or scalar of maintainer(s)
 330
 331 =item links_only -- return only links, not htmlized links, defaults to
 332 returning htmlized links.
 333
 334 =item class -- class of the a href, defaults to ''
 335
 336 =back
 337
 338 =cut
 339
 340 sub package_links {
 341      my %param = validate_with(params => \@_,
 342                                spec   => {package => {type => SCALAR|ARRAYREF,
 343                                                       optional => 1,
 344                                                      },
 345                                           source  => {type => SCALAR|ARRAYREF,
 346                                                       optional => 1,
 347                                                      },
 348                                           maintainer => {type => SCALAR|ARRAYREF,
 349                                                          optional => 1,
 350                                                         },
 351                                           submitter => {type => SCALAR|ARRAYREF,
 352                                                         optional => 1,
 353                                                        },
 354                                           owner     => {type => SCALAR|ARRAYREF,
 355                                                         optional => 1,
 356                                                        },
 357                                           links_only => {type => BOOLEAN,
 358                                                          default => 0,
 359                                                         },
 360                                           class => {type => SCALAR,
 361                                                     default => '',
 362                                                    },
 363                                           separator => {type => SCALAR,
 364                                                         default => ', ',
 365                                                        },
 366                                          },
 367                               );
 368      my @links = ();
 369      push @links, map {(pkg_url(source => $_),$_)
 370                   } make_list($param{source}) if exists $param{source};
 371      push @links, map {my $addr = getparsedaddrs($_);
 372                        $addr = defined $addr?$addr->address:'';
 373                        (pkg_url(maint => $addr),$_)
 374                   } make_list($param{maintainer}) if exists $param{maintainer};
 375      push @links, map {my $addr = getparsedaddrs($_);
 376                        $addr = defined $addr?$addr->address:'';
 377                        (pkg_url(owner => $addr),$_)
 378                   } make_list($param{owner}) if exists $param{owner};
 379      push @links, map {my $addr = getparsedaddrs($_);
 380                        $addr = defined $addr?$addr->address:'';
 381                        (pkg_url(submitter => $addr),$_)
 382                   } make_list($param{submitter}) if exists $param{submitter};
 383      push @links, map {(pkg_url(pkg => $_),
 384                         html_escape($_))
 385                   } make_list($param{package}) if exists $param{package};
 386      my @return = ();
 387      my ($link,$link_name);
 388      my $class = '';
 389      if (length $param{class}) {
 390           $class = q( class=").html_escape($param{class}).q(");
 391      }
 392      while (($link,$link_name) = splice(@links,0,2)) {
 393           if ($param{links_only}) {
 394                push @return,$link
 395           }
 396           else {
 397                push @return,
 398                     qq(<a$class href=").
 399                          html_escape($link).q(">).
 400                               html_escape($link_name).q(</a>);
 401           }
 402      }
 403      if (wantarray) {
 404           return @return;
 405      }
 406      else {
 407           return join($param{separator},@return);
 408      }
 409 }
 410
 411 =head2 bug_links
 412
 413      join(', ', bug_links(bug => \@packages))
 414
 415 Given a list of bugs, return a list of html which links to the bugs
 416
 417 =over
 418
 419 =item bug -- arrayref or scalar of bug(s)
 420
 421 =item links_only -- return only links, not htmlized links, defaults to
 422 returning htmlized links.
 423
 424 =item class -- class of the a href, defaults to ''
 425
 426 =back
 427
 428 =cut
 429
 430 sub bug_links {
 431      my %param = validate_with(params => \@_,
 432                                spec   => {bug => {type => SCALAR|ARRAYREF,
 433                                                   optional => 1,
 434                                                  },
 435                                           links_only => {type => BOOLEAN,
 436                                                          default => 0,
 437                                                         },
 438                                           class => {type => SCALAR,
 439                                                     default => '',
 440                                                    },
 441                                          },
 442                               );
 443      my @links;
 444      push @links, map {(bug_url($_),$_)
 445                   } make_list($param{bug}) if exists $param{bug};
 446      my @return;
 447      my ($link,$link_name);
 448      my $class = '';
 449      if (length $param{class}) {
 450           $class = q( class=").html_escape($param{class}).q(");
 451      }
 452      while (($link,$link_name) = splice(@links,0,2)) {
 453           if ($param{links_only}) {
 454                push @return,$link
 455           }
 456           else {
 457                push @return,
 458                     qq(<a$class href=").
 459                          html_escape($link).q(">).
 460                               html_escape($link_name).q(</a>);
 461           }
 462      }
 463      return @return;
 464 }
 465
 466
 467
 468 =head2 maybelink
 469
 470      maybelink($in);
 471      maybelink('http://foobarbaz,http://bleh',qr/[, ]+/);
 472      maybelink('http://foobarbaz,http://bleh',qr/[, ]+/,', ');
 473
 474
 475 In the first form, links the link if it looks like a link. In the
 476 second form, first splits based on the regex, then reassembles the
 477 link, linking things that look like links. In the third form, rejoins
 478 the split links with commas and spaces.
 479
 480 =cut
 481
 482 sub maybelink {
 483     my ($links,$regex,$join) = @_;
 484     $join = ' ' if not defined $join;
 485     my @return;
 486     my @segments;
 487     if (defined $regex) {
 488          @segments = split $regex, $links;
 489     }
 490     else {
 491          @segments = ($links);
 492     }
 493     for my $in (@segments) {
 494          if ($in =~ /^[a-zA-Z0-9+.-]+:/) { # RFC 1738 scheme
 495               push @return, qq{<a href="$in">} . html_escape($in) . '</a>';
 496          } else {
 497               push @return, html_escape($in);
 498          }
 499     }
 500     return @return?join($join,@return):'';
 501 }
 502
 503
 504 =head2 htmlize_addresslinks
 505
 506      htmlize_addresslinks($prefixfunc,$urlfunc,$addresses,$class);
 507
 508
 509 Generate a comma-separated list of HTML links to each address given in
 510 $addresses, which should be a comma-separated list of RFC822
 511 addresses. $urlfunc should be a reference to a function like mainturl
 512 or submitterurl which returns the URL for each individual address.
 513
 514
 515 =cut
 516
 517 sub htmlize_addresslinks {
 518      my ($prefixfunc, $urlfunc, $addresses,$class) = @_;
 519      carp "htmlize_addresslinks is deprecated";
 520
 521      $class = defined $class?qq(class="$class" ):'';
 522      if (defined $addresses and $addresses ne '') {
 523           my @addrs = getparsedaddrs($addresses);
 524           my $prefix = (ref $prefixfunc) ?
 525                $prefixfunc->(scalar @addrs):$prefixfunc;
 526           return $prefix .
 527                join(', ', map
 528                     { sprintf qq(<a ${class}).
 529                            'href="%s">%s</a>',
 530                                 $urlfunc->($_->address),
 531                                      html_escape($_->format) ||
 532                                           '(unknown)'
 533                                      } @addrs
 534                    );
 535      }
 536      else {
 537           my $prefix = (ref $prefixfunc) ?
 538                $prefixfunc->(1) : $prefixfunc;
 539           return sprintf '%s<a '.$class.'href="%s">(unknown)</a>',
 540                $prefix, $urlfunc->('');
 541      }
 542 }
 543
 544 sub emailfromrfc822{
 545      my $addr = getparsedaddrs($_[0] || "");
 546      $addr = defined $addr?$addr->address:'';
 547      return $addr;
 548 }
 549
 550 sub mainturl { pkg_url(maint => emailfromrfc822($_[0])); }
 551 sub submitterurl { pkg_url(submitter => emailfromrfc822($_[0])); }
 552 sub htmlize_maintlinks {
 553     my ($prefixfunc, $maints) = @_;
 554     carp "htmlize_maintlinks is deprecated";
 555     return htmlize_addresslinks($prefixfunc, \&mainturl, $maints);
 556 }
 557
 558
 559 our $_maintainer;
 560 our $_maintainer_rev;
 561
 562 =head2 bug_linklist
 563
 564      bug_linklist($separator,$class,@bugs)
 565
 566 Creates a set of links to C<@bugs> separated by C<$separator> with
 567 link class C<$class>.
 568
 569 XXX Use L<Params::Validate>; we want to be able to support query
 570 arguments here too; we should be able to combine bug_links and this
 571 function into one. [Hell, bug_url should be one function with this one
 572 too.]
 573
 574 =cut
 575
 576
 577 sub bug_linklist{
 578      my ($sep,$class,@bugs) = @_;
 579      return join($sep,bug_links(bug=>\@bugs,class=>$class));
 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