From: Don Armstrong Date: Sun, 22 Oct 2006 09:48:36 +0000 (-0700) Subject: * Add Debbugs::SOAP::Status X-Git-Tag: release/2.6.0~585^2^2~83 X-Git-Url: https://git.donarmstrong.com/?a=commitdiff_plain;h=a54f07e01f95b7ab702a9f08375dc8dad3394ac9;p=debbugs.git * Add Debbugs::SOAP::Status * Merge changes from mainline - Debbugs::Bugs * Add MLDBM index support * Add function support - Debbugs::CGI * Add set_url_params to set URL_PARARAMS * Fix bug_url to do the same * Add version_url to create a link to the version.cgi script * Move a grip of functions from common.pl here - Debbugs::Common * Ditch useless locals() - Debbugs::Config * Add $gVersionPackagesDir $gVersionIndex, $gBinarySourceMap, and $gSourceBinaryMap * Add %gSearchEstraier - Debbugs::Estraier * Add remove_old_messages function; not called because the indexes which are needed aren't currently created. - Debbugs::Package * Fix typo in getversions - Debbugs::Status * Use Debbugs Mime * move some functions out of Debbugs::Status - Debbugs::User * Use the Debbugs::Config module - add_bug_to_estraier * Use Debbugs::Config * Beginings of hooks to remove old messages - cgi/common.pl * Most functions moved out to other modules and 'use'd here. --- a54f07e01f95b7ab702a9f08375dc8dad3394ac9 diff --cc Debbugs/Bugs.pm index e2293261,00000000,00000000..e4b9f951 mode 100644,000000,000000..100644 --- a/Debbugs/Bugs.pm +++ b/Debbugs/Bugs.pm @@@@ -1,308 -1,0 -1,0 +1,411 @@@@ ++ ++package Debbugs::Bugs; ++ ++=head1 NAME ++ ++Debbugs::Bugs -- Bug selection routines for debbugs ++ ++=head1 SYNOPSIS ++ ++use Debbugs::Bugs qw(get_bugs); ++ ++ ++=head1 DESCRIPTION ++ ++This module is a replacement for all of the various methods of ++selecting different types of bugs. ++ ++It implements a single function, get_bugs, which defines the master ++interface for selecting bugs. ++ ++It attempts to use subsidiary functions to actually do the selection, ++in the order specified in the configuration files. [Unless you're ++insane, they should be in order from fastest (and often most ++incomplete) to slowest (and most complete).] ++ ++=head1 BUGS ++ ++=head1 FUNCTIONS ++ ++=cut ++ ++use warnings; ++use strict; ++use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); ++use base qw(Exporter); ++ ++BEGIN{ ++ $VERSION = 1.00; ++ $DEBUG = 0 unless defined $DEBUG; ++ ++ @EXPORT = (); ++ %EXPORT_TAGS = (); ++ @EXPORT_OK = (qw(get_bugs)); ++ $EXPORT_TAGS{all} = [@EXPORT_OK]; ++} ++ ++use Debbugs::Config qw(:config); ++use Params::Validate qw(validate_with :types); ++use IO::File; ++use Debbugs::Status; ++use Debbugs::Packages qw(getsrcpkgs); +++use Fcntl qw(O_RDONLY); +++use MLDBM qw(DB_File Storable); ++ ++=head2 get_bugs ++ ++ get_bugs() ++ ++=head3 Parameters ++ ++The following parameters can either be a single scalar or a reference ++to an array. The parameters are ANDed together, and the elements of ++arrayrefs are a parameter are ORed. Future versions of this may allow - for limited regular expressions. +++for limited regular expressions, and/or more complex expressions. ++ ++=over ++ ++=item package -- name of the binary package ++ ++=item src -- name of the source package ++ ++=item maint -- address of the maintainer ++ ++=item maintenc -- encoded address of the maintainer ++ ++=item submitter -- address of the submitter ++ ++=item severity -- severity of the bug ++ ++=item status -- status of the bug ++ ++=item tag -- bug tags ++ ++=item owner -- owner of the bug ++ ++=item dist -- distribution (I don't know about this one yet) ++ ++=item bugs -- list of bugs to search within ++ +++=item function -- see description below +++ ++=back ++ ++=head3 Special options ++ ++The following options are special options used to modulate how the ++searches are performed. ++ ++=over ++ ++=item archive -- whether to search archived bugs or normal bugs; ++defaults to false. ++ ++=item usertags -- set of usertags and the bugs they are applied to ++ ++=back ++ ++ ++=head3 Subsidiary routines ++ ++All subsidiary routines get passed exactly the same set of options as ++get_bugs. If for some reason they are unable to handle the options ++passed (for example, they don't have the right type of index for the ++type of selection) they should die as early as possible. [Using ++Params::Validate and/or die when files don't exist makes this fairly ++trivial.] ++ ++This function will then immediately move on to the next subroutine, ++giving it the same arguments. ++ +++=head3 function +++ +++This option allows you to provide an arbitrary function which will be +++given the information in the index.db file. This will be super, super +++slow, so only do this if there's no other way to write the search. +++ +++You'll be given a list (which you can turn into a hash) like the +++following: +++ +++ (pkg => ['a','b'], # may be a scalar (most common) +++ bug => 1234, +++ status => 'pending', +++ submitter => 'boo@baz.com', +++ severity => 'serious', +++ tags => ['a','b','c'], # may be an empty arrayref +++ ) +++ +++The function should return 1 if the bug should be included; 0 if the +++bug should not. +++ ++=cut ++ ++sub get_bugs{ ++ my %param = validate_with(params => \@_, ++ spec => {package => {type => SCALAR|ARRAYREF, ++ optional => 1, ++ }, ++ src => {type => SCALAR|ARRAYREF, ++ optional => 1, ++ }, ++ maint => {type => SCALAR|ARRAYREF, ++ optional => 1, ++ }, ++ maintenc => {type => SCALAR|ARRAYREF, ++ optional => 1, ++ }, ++ submitter => {type => SCALAR|ARRAYREF, ++ optional => 1, ++ }, ++ severity => {type => SCALAR|ARRAYREF, ++ optional => 1, ++ }, ++ status => {type => SCALAR|ARRAYREF, ++ optional => 1, ++ }, ++ tag => {type => SCALAR|ARRAYREF, ++ optional => 1, ++ }, ++ owner => {type => SCALAR|ARRAYREF, ++ optional => 1, ++ }, ++ dist => {type => SCALAR|ARRAYREF, ++ optional => 1, ++ }, +++ function => {type => CODEREF, +++ optional => 1, +++ }, ++ bugs => {type => SCALAR|ARRAYREF, ++ optional => 1, ++ }, ++ archive => {type => BOOLEAN, ++ default => 0, ++ }, ++ usertags => {type => HASHREF, ++ optional => 1, ++ }, ++ }, ++ ); ++ ++ # Normalize options ++ my %options = %param; ++ my @bugs; ++ # A configuration option will set an array that we'll use here instead. - for my $routine (qw(Debbugs::Bugs::get_bugs_flatfile)) { +++ for my $routine (qw(Debbugs::Bugs::get_bugs_by_idx Debbugs::Bugs::get_bugs_flatfile)) { ++ my ($package) = $routine =~ m/^(.+)\:\:/; ++ eval "use $package;"; ++ if ($@) { ++ # We output errors here because using an invalid function ++ # in the configuration file isn't something that should ++ # be done. ++ warn "use $package failed with $@"; ++ next; ++ } ++ @bugs = eval "${routine}(\%options)"; ++ if ($@) { ++ ++ # We don't output errors here, because failure here ++ # via die may be a perfectly normal thing. ++ print STDERR "$@" if $DEBUG; ++ next; ++ } ++ last; ++ } ++ # If no one succeeded, die ++ if ($@) { ++ die "$@"; ++ } ++ return @bugs; ++} ++ +++=head2 get_bugs_by_idx +++ +++This routine uses the by-$index.idx indicies to try to speed up +++searches. +++ +++ +++=cut +++ +++sub get_bugs_by_idx{ +++ my %param = validate_with(params => \@_, +++ spec => {package => {type => SCALAR|ARRAYREF, +++ optional => 1, +++ }, +++ submitter => {type => SCALAR|ARRAYREF, +++ optional => 1, +++ }, +++ severity => {type => SCALAR|ARRAYREF, +++ optional => 1, +++ }, +++ tag => {type => SCALAR|ARRAYREF, +++ optional => 1, +++ }, +++ archive => {type => BOOLEAN, +++ default => 0, +++ }, +++ }, +++ ); +++ my %bugs = (); +++ my $keys = keys %param - 1; +++ die "Need at least 1 key to search by" unless $keys; +++ my $arc = $params{archive} ? '-arc':'' +++ my %idx; +++ for my $key (keys %param) { +++ my $index = $key; +++ $index = 'submitter-email' if $key eq 'submitter'; +++ $index = "$config{spool_dir}/by-${index}${arc}.idx" +++ tie %idx, MLDBM => $index, O_RDONLY +++ or die "Unable to open $index $!"; +++ for my $search (__make_list($param{$key})) { +++ next unless defined $idx{$search}; +++ for my $bug (keys %{$idx{$search}}) { +++ # increment the number of searches that this bug matched +++ $bugs{$bug}++; +++ } +++ } +++ untie %idx or die 'Unable to untie %idx'; +++ } +++ # Throw out results that do not match all of the search specifications +++ return map {$keys == $bugs{$bug}?($bug):()} keys %bugs; +++} +++ +++ +++=head2 get_bugs_flatfile +++ +++This is the fallback search routine. It should be able to complete all +++searches. [Or at least, that's the idea.] +++ +++=cut +++ ++sub get_bugs_flatfile{ ++ my %param = validate_with(params => \@_, ++ spec => {package => {type => SCALAR|ARRAYREF, ++ optional => 1, ++ }, ++ src => {type => SCALAR|ARRAYREF, ++ optional => 1, ++ }, ++ maint => {type => SCALAR|ARRAYREF, ++ optional => 1, ++ }, ++ maintenc => {type => SCALAR|ARRAYREF, ++ optional => 1, ++ }, ++ submitter => {type => SCALAR|ARRAYREF, ++ optional => 1, ++ }, ++ severity => {type => SCALAR|ARRAYREF, ++ optional => 1, ++ }, ++ status => {type => SCALAR|ARRAYREF, ++ optional => 1, ++ }, ++ tag => {type => SCALAR|ARRAYREF, ++ optional => 1, ++ }, ++# not yet supported ++# owner => {type => SCALAR|ARRAYREF, ++# optional => 1, ++# }, ++# dist => {type => SCALAR|ARRAYREF, ++# optional => 1, ++# }, ++ archive => {type => BOOLEAN, ++ default => 1, ++ }, ++ usertags => {type => HASHREF, ++ optional => 1, ++ }, +++ function => {type => CODEREF, +++ optional => 1, +++ }, ++ }, ++ ); ++ my $flatfile; ++ if ($param{archive}) { ++ $flatfile = new IO::File "$debbugs::gSpoolDir/index.archive", 'r' ++ or die "Unable to open $debbugs::gSpoolDir/index.archive for reading: $!"; ++ } ++ else { ++ $flatfile = new IO::File "$debbugs::gSpoolDir/index.db", 'r' ++ or die "Unable to open $debbugs::gSpoolDir/index.db for reading: $!"; ++ } ++ my %usertag_bugs; ++ if (exists $param{tag} and exists $param{usertags}) { ++ ++ # This complex slice makes a hash with the bugs which have the ++ # usertags passed in $param{tag} set. ++ @usertag_bugs{map {@{$_}} ++ @{$param{usertags}}{__make_list($param{tag})} ++ } = (1) x @{$param{usertags}}{__make_list($param{tag})} ++ } ++ my @bugs; ++ while (<$flatfile>) { ++ next unless m/^(\S+)\s+(\d+)\s+(\d+)\s+(\S+)\s+\[\s*([^]]*)\s*\]\s+(\w+)\s+(.*)$/; ++ my ($pkg,$bug,$status,$submitter,$severity,$tags) = ($1,$2,$3,$4,$5,$6,$7); ++ next if exists $param{bug} and not grep {$bug == $_} __make_list($param{bugs}); ++ if (exists $param{pkg}) { ++ my @packages = splitpackages($pkg); ++ next unless grep { my $pkg_list = $_; ++ grep {$pkg_list eq $_} __make_list($param{pkg}) ++ } @packages; ++ } ++ if (exists $param{src}) { ++ my @src_packages = map { getsrcpkgs($_)} __make_list($param{src}); ++ my @packages = splitpackages($pkg); ++ next unless grep { my $pkg_list = $_; ++ grep {$pkg_list eq $_} @packages ++ } @src_packages; ++ } ++ if (exists $param{submitter}) { ++ my @p_addrs = map {$_->address} ++ map {lc(getparsedaddrs($_))} ++ __make_list($param{submitter}); ++ my @f_addrs = map {$_->address} ++ getparsedaddrs($submitter||''); ++ next unless grep { my $f_addr = $_; ++ grep {$f_addr eq $_} @p_addrs ++ } @f_addrs; ++ } ++ next if exists $param{severity} and not grep {$severity eq $_} __make_list($param{severity}); ++ next if exists $param{status} and not grep {$status eq $_} __make_list($param{status}); ++ if (exists $param{tag}) { ++ my $bug_ok = 0; ++ # either a normal tag, or a usertag must be set ++ $bug_ok = 1 if exists $param{usertags} and $usertag_bugs{$bug}; ++ my @bug_tags = split ' ', $tags; ++ $bug_ok = 1 if grep {my $bug_tag = $_; ++ grep {$bug_tag eq $_} __make_list($param{tag}); ++ } @bug_tags; ++ next unless $bug_ok; ++ } +++ # We do this last, because a function may be slow... +++ if (exists $param{function}) { +++ my @bug_tags = split ' ', $tags; +++ my @packages = splitpackages($pkg); +++ my $package = (@packages > 1)?\@packages:$packages[0], +++ next unless +++ $param{function}->(pkg => $package, +++ bug => $bug, +++ status => $status, +++ submitter => $submitter, +++ severity => $severity, +++ tags => \@bug_tags, +++ ); +++ } ++ push @bugs, $bug; ++ } ++ return @bugs; ++} ++ ++ ++# This private subroutine takes a scalar and turns it ++# into a list; transforming arrayrefs into their contents ++# along the way. ++sub __make_list{ ++ return map {ref($_) eq 'ARRAY'?@{$_}:$_} @_; ++} ++ ++1; ++ ++__END__ diff --cc Debbugs/CGI.pm index 4b450de3,00000000,00000000..a38a6a79 mode 100644,000000,000000..100644 --- a/Debbugs/CGI.pm +++ b/Debbugs/CGI.pm @@@@ -1,178 -1,0 -1,0 +1,550 @@@@ ++ ++package Debbugs::CGI; ++ ++=head1 NAME ++ ++Debbugs::CGI -- General routines for the cgi scripts ++ ++=head1 SYNOPSIS ++ ++use Debbugs::CGI qw(:url :html); ++ ++html_escape(bug_url($ref,mbox=>'yes',mboxstatus=>'yes')); ++ ++=head1 DESCRIPTION ++ ++This module is a replacement for parts of common.pl; subroutines in ++common.pl will be gradually phased out and replaced with equivalent ++(or better) functionality here. ++ ++=head1 BUGS ++ ++None known. ++ ++=cut ++ ++use warnings; ++use strict; ++use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); ++use base qw(Exporter); ++use Debbugs::URI; ++use HTML::Entities; ++use Debbugs::Common qw(); +++use Params::Validate qw(validate_with :types); +++use Debbugs::Config qw(:config); +++use Mail::Address; +++use POSIX qw(ceil); +++ +++my %URL_PARAMS = (); +++ ++ ++BEGIN{ ++ ($VERSION) = q$Revision: 1.3 $ =~ /^Revision:\s+([^\s+])/; ++ $DEBUG = 0 unless defined $DEBUG; ++ ++ @EXPORT = (); - %EXPORT_TAGS = (url => [qw(bug_url)], - html => [qw(html_escape)], +++ %EXPORT_TAGS = (url => [qw(bug_url bug_links bug_linklist maybelink), +++ qw(set_url_params pkg_url version_url), +++ ], +++ html => [qw(html_escape htmlize_bugs htmlize_packagelinks), +++ qw(maybelink htmlize_addresslinks), +++ ], +++ util => [qw(getparsedaddrs)] ++ #status => [qw(getbugstatus)], ++ ); ++ @EXPORT_OK = (); - Exporter::export_ok_tags(qw(url html)); +++ Exporter::export_ok_tags(qw(url html util)); ++ $EXPORT_TAGS{all} = [@EXPORT_OK]; ++} ++ ++ ++ +++=head2 set_url_params +++ +++ set_url_params($uri); +++ +++ +++Sets the url params which will be used to generate urls. +++ +++=cut +++ +++sub set_url_params{ +++ if (@_ > 1) { +++ %URL_PARAMS = @_; +++ } +++ else { +++ my $url = Debbugs::URI->new($_[0]||''); +++ %URL_PARAMS = %{$url->query_form_hash}; +++ } +++} +++ ++ ++=head2 bug_url ++ ++ bug_url($ref,mbox=>'yes',mboxstat=>'yes'); ++ ++Constructs urls which point to a specific ++ +++XXX use Params::Validate +++ ++=cut ++ ++sub bug_url{ ++ my $ref = shift; - my %params = @_; +++ my %params; +++ if (@_ % 2) { +++ shift; +++ %params = (%URL_PARAMS,@_); +++ } +++ else { +++ %params = @_; +++ } ++ my $url = Debbugs::URI->new('bugreport.cgi?'); ++ $url->query_form(bug=>$ref,%params); ++ return $url->as_string; ++} ++ +++sub pkg_url{ +++ my %params; +++ if (@_ % 2) { +++ shift; +++ %params = (%URL_PARAMS,@_); +++ } +++ else { +++ %params = @_; +++ } +++ my $url = Debbugs::URI->new('pkgreport.cgi?'); +++ $url->query_form(%params); +++ return $url->as_string; +++} +++ +++=head2 version_url +++ +++ version_url($package,$found,$fixed) +++ +++Creates a link to the version cgi script +++ +++=cut +++ +++sub version_url{ +++ my ($package,$found,$fixed) = @_; +++ my $url = Debbugs::URI->new('version.cgi?'); +++ $url->query_form(package => $package, +++ found => $found, +++ fixed => $fixed, +++ ); +++ return $url->as_string; +++} +++ ++=head2 html_escape ++ ++ html_escape($string) ++ ++Escapes html entities by calling HTML::Entities::encode_entities; ++ ++=cut ++ ++sub html_escape{ ++ my ($string) = @_; ++ ++ return HTML::Entities::encode_entities($string) ++} ++ ++my %common_bugusertags; ++ ++# =head2 get_bug_status ++# ++# my $status = getbugstatus($bug_num) ++# ++# my $status = getbugstatus($bug_num,$bug_index) ++# ++# ++# =cut ++# ++# sub get_bug_status { ++# my ($bugnum,$bugidx) = @_; ++# ++# my %status; ++# ++# if (defined $bugidx and exists $bugidx->{$bugnum}) { ++# %status = %{ $bugidx->{$bugnum} }; ++# $status{pending} = $status{ status }; ++# $status{id} = $bugnum; ++# return \%status; ++# } ++# ++# my $location = getbuglocation($bugnum, 'summary'); ++# return {} if not length $location; ++# %status = %{ readbug( $bugnum, $location ) }; ++# $status{id} = $bugnum; ++# ++# ++# if (defined $common_bugusertags{$bugnum}) { ++# $status{keywords} = "" unless defined $status{keywords}; ++# $status{keywords} .= " " unless $status{keywords} eq ""; ++# $status{keywords} .= join(" ", @{$common_bugusertags{$bugnum}}); ++# } ++# $status{tags} = $status{keywords}; ++# my %tags = map { $_ => 1 } split ' ', $status{tags}; ++# ++# $status{"package"} =~ s/\s*$//; ++# $status{"package"} = 'unknown' if ($status{"package"} eq ''); ++# $status{"severity"} = 'normal' if ($status{"severity"} eq ''); ++# ++# $status{"pending"} = 'pending'; ++# $status{"pending"} = 'forwarded' if (length($status{"forwarded"})); ++# $status{"pending"} = 'pending-fixed' if ($tags{pending}); ++# $status{"pending"} = 'fixed' if ($tags{fixed}); ++# ++# my @versions; ++# if (defined $common_version) { ++# @versions = ($common_version); ++# } elsif (defined $common_dist) { ++# @versions = getversions($status{package}, $common_dist, $common_arch); ++# } ++# ++# # TODO: This should probably be handled further out for efficiency and ++# # for more ease of distinguishing between pkg= and src= queries. ++# my @sourceversions = makesourceversions($status{package}, $common_arch, ++# @versions); ++# ++# if (@sourceversions) { ++# # Resolve bugginess states (we might be looking at multiple ++# # architectures, say). Found wins, then fixed, then absent. ++# my $maxbuggy = 'absent'; ++# for my $version (@sourceversions) { ++# my $buggy = buggyversion($bugnum, $version, \%status); ++# if ($buggy eq 'found') { ++# $maxbuggy = 'found'; ++# last; ++# } elsif ($buggy eq 'fixed' and $maxbuggy ne 'found') { ++# $maxbuggy = 'fixed'; ++# } ++# } ++# if ($maxbuggy eq 'absent') { ++# $status{"pending"} = 'absent'; ++# } elsif ($maxbuggy eq 'fixed') { ++# $status{"pending"} = 'done'; ++# } ++# } ++# ++# if (length($status{done}) and ++# (not @sourceversions or not @{$status{fixed_versions}})) { ++# $status{"pending"} = 'done'; ++# } ++# ++# return \%status; ++# } ++ ++ +++# htmlize_bugs(bugs=>[@bugs]); +++=head2 htmlize_bugs +++ +++ htmlize_bugs({bug=>1,status=>\%status,extravars=>\%extra},{bug=>...}}); +++ +++Turns a list of bugs into an html snippit of the bugs. +++ +++=cut +++ +++sub htmlize_bugs{ +++ my @bugs = @_; +++ my @html; +++ +++ for my $bug (@bugs) { +++ my $html = sprintf "
  • #%d: %s\n
    ", +++ bug_url($bug->{bug}), $bug->{bug}, html_escape($bug->{status}{subject}); +++ $html .= htmlize_bugstatus($bug->{status}) . "\n"; +++ } +++ return @html; +++} +++ +++ +++sub htmlize_bugstatus { +++ my %status = %{$_[0]}; +++ +++ my $result = ""; +++ +++ my $showseverity; +++ if ($status{severity} eq $config{default_severity}) { +++ $showseverity = ''; +++ } elsif (isstrongseverity($status{severity})) { +++ $showseverity = "Severity: $status{severity};\n"; +++ } else { +++ $showseverity = "Severity: $status{severity};\n"; +++ } +++ +++ $result .= htmlize_packagelinks($status{"package"}, 1); +++ +++ my $showversions = ''; +++ if (@{$status{found_versions}}) { +++ my @found = @{$status{found_versions}}; +++ local $_; +++ s{/}{ } foreach @found; +++ $showversions .= join ', ', map html_escape($_), @found; +++ } +++ if (@{$status{fixed_versions}}) { +++ $showversions .= '; ' if length $showversions; +++ $showversions .= 'fixed: '; +++ my @fixed = @{$status{fixed_versions}}; +++ $showversions .= join ', ', map {s#/##; html_escape($_)} @fixed; +++ } +++ $result .= " ($showversions)" if length $showversions; +++ $result .= ";\n"; +++ +++ $result .= $showseverity; +++ $result .= htmlize_addresslinks("Reported by: ", \&submitterurl, +++ $status{originator}); +++ $result .= ";\nOwned by: " . html_escape($status{owner}) +++ if length $status{owner}; +++ $result .= ";\nTags: " +++ . html_escape(join(", ", sort(split(/\s+/, $status{tags})))) +++ . "" +++ if (length($status{tags})); +++ +++ $result .= ";\nMerged with ". +++ bug_linklist(', ', +++ 'submitter', +++ split(/ /,$status{mergedwith})) +++ if length $status{mergedwith}; +++ $result .= ";\nBlocked by ". +++ bug_linklist(", ", +++ 'submitter', +++ split(/ /,$status{blockedby})) +++ if length $status{blockedby}; +++ $result .= ";\nBlocks ". +++ bug_linklist(", ", +++ 'submitter', +++ split(/ /,$status{blocks}) +++ ) +++ if length $status{blocks}; +++ +++ my $days = 0; +++ if (length($status{done})) { +++ $result .= "
    Done: " . html_escape($status{done}); +++ $days = ceil($debbugs::gRemoveAge - -M buglog($status{id})); +++ if ($days >= 0) { +++ $result .= ";\nWill be archived" . ( $days == 0 ? " today" : $days == 1 ? " in $days day" : " in $days days" ) . ""; +++ } else { +++ $result .= ";\nArchived"; +++ } +++ } +++ else { +++ if (length($status{forwarded})) { +++ $result .= ";\nForwarded to " +++ . maybelink($status{forwarded}); +++ } +++ my $daysold = int((time - $status{date}) / 86400); # seconds to days +++ if ($daysold >= 7) { +++ my $font = ""; +++ my $efont = ""; +++ $font = "em" if ($daysold > 30); +++ $font = "strong" if ($daysold > 60); +++ $efont = "" if ($font); +++ $font = "<$font>" if ($font); +++ +++ my $yearsold = int($daysold / 365); +++ $daysold -= $yearsold * 365; +++ +++ $result .= ";\n $font"; +++ my @age; +++ push @age, "1 year" if ($yearsold == 1); +++ push @age, "$yearsold years" if ($yearsold > 1); +++ push @age, "1 day" if ($daysold == 1); +++ push @age, "$daysold days" if ($daysold > 1); +++ $result .= join(" and ", @age); +++ $result .= " old$efont"; +++ } +++ } +++ +++ $result .= "."; +++ +++ return $result; +++} +++ +++# Split a package string from the status file into a list of package names. +++sub splitpackages { +++ my $pkgs = shift; +++ return unless defined $pkgs; +++ return map lc, split /[ \t?,()]+/, $pkgs; +++} +++ +++ +++=head2 htmlize_packagelinks +++ +++ htmlize_packagelinks +++ +++Given a scalar containing a list of packages separated by something +++that L can separate, returns a +++formatted set of links to packages. +++ +++=cut +++ +++sub htmlize_packagelinks { +++ my ($pkgs,$strong) = @_; +++ return unless defined $pkgs and $pkgs ne ''; +++ my @pkglist = splitpackages($pkgs); +++ +++ $strong = 0; +++ my $openstrong = $strong ? '' : ''; +++ my $closestrong = $strong ? '' : ''; +++ +++ return 'Package' . (@pkglist > 1 ? 's' : '') . ': ' . +++ join(', ', +++ map { +++ '' . +++ $openstrong . html_escape($_) . $closestrong . '' +++ } @pkglist +++ ); +++} +++ +++ +++=head2 maybelink +++ +++ maybelink($in); +++ maybelink('http://foobarbaz,http://bleh',qr/[, ]+/); +++ maybelink('http://foobarbaz,http://bleh',qr/[, ]+/,', '); +++ +++ +++In the first form, links the link if it looks like a link. In the +++second form, first splits based on the regex, then reassembles the +++link, linking things that look like links. In the third form, rejoins +++the split links with commas and spaces. +++ +++=cut +++ +++sub maybelink { +++ my ($links,$regex,$join) = @_; +++ $join = ' ' if not defined $join; +++ my @return; +++ my @segments; +++ if (defined $regex) { +++ @segments = split $regex, $links; +++ } +++ else { +++ @segments = ($links); +++ } +++ for my $in (@segments) { +++ if ($in =~ /^[a-zA-Z0-9+.-]+:/) { # RFC 1738 scheme +++ push @return, qq{} . html_escape($in) . ''; +++ } else { +++ push @return, html_escape($in); +++ } +++ } +++ return @return?join($join,@return):''; +++} +++ +++ +++=head2 htmlize_addresslinks +++ +++ htmlize_addresslinks($prefixfunc,$urlfunc,$addresses,$class); +++ +++ +++Generate a comma-separated list of HTML links to each address given in +++$addresses, which should be a comma-separated list of RFC822 +++addresses. $urlfunc should be a reference to a function like mainturl +++or submitterurl which returns the URL for each individual address. +++ +++ +++=cut +++ +++sub htmlize_addresslinks { +++ my ($prefixfunc, $urlfunc, $addresses,$class) = @_; +++ $class = defined $class?qq(class="$class" ):''; +++ if (defined $addresses and $addresses ne '') { +++ my @addrs = getparsedaddrs($addresses); +++ my $prefix = (ref $prefixfunc) ? +++ $prefixfunc->(scalar @addrs):$prefixfunc; +++ return $prefix . +++ join ', ', map +++ { sprintf qq(%s', +++ $urlfunc->($_->address), +++ html_escape($_->format) || +++ '(unknown)' +++ } @addrs; +++ } +++ else { +++ my $prefix = (ref $prefixfunc) ? +++ $prefixfunc->(1) : $prefixfunc; +++ return sprintf '%s(unknown)', +++ $prefix, $urlfunc->(''); +++ } +++} +++ +++ +++ +++my %_parsedaddrs; +++sub getparsedaddrs { +++ my $addr = shift; +++ return () unless defined $addr; +++ return @{$_parsedaddrs{$addr}} if exists $_parsedaddrs{$addr}; +++ @{$_parsedaddrs{$addr}} = Mail::Address->parse($addr); +++ return @{$_parsedaddrs{$addr}}; +++} +++ +++ +++=head2 bug_links +++ +++ bug_links($one_bug); +++ bug_links($starting_bug,$stoping_bugs,); +++ +++Creates a set of links to bugs, starting with bug number +++$starting_bug, and finishing with $stoping_bug; if only one bug is +++passed, makes a link to only a single bug. +++ +++The content of the link is the bug number. +++ +++XXX Use L; we want to be able to support query +++arguments here too. +++ +++=cut +++ +++sub bug_links{ +++ my ($start,$stop,$query_arguments) = @_; +++ $stop = $stop || $start; +++ $query_arguments ||= ''; +++ my @output; +++ for my $bug ($start..$stop) { +++ push @output,'$bug); +++ } +++ return join(', ',@output); +++} +++ +++=head2 bug_linklist +++ +++ bug_linklist($separator,$class,@bugs) +++ +++Creates a set of links to C<@bugs> separated by C<$separator> with +++link class C<$class>. +++ +++XXX Use L; we want to be able to support query +++arguments here too; we should be able to combine bug_links and this +++function into one. [Hell, bug_url should be one function with this one +++too.] +++ +++=cut +++ +++ +++sub bug_linklist{ +++ my ($sep,$class,@bugs) = @_; +++ if (length $class) { +++ $class = qq(class="$class" ); +++ } +++ return join($sep,map{qq(#$_) +++ } @bugs); +++} +++ +++ +++ ++ ++1; ++ ++ ++__END__ ++ ++ ++ ++ ++ ++ diff --cc Debbugs/Common.pm index a86460b0,b940edfe,b940edfe..99c68fdf --- a/Debbugs/Common.pm +++ b/Debbugs/Common.pm @@@@ -1,252 -1,57 -1,57 +1,253 @@@@ --package Debbugs::Common; ++package Debbugs::Common; ++ ++=head1 NAME ++ ++Debbugs::Common -- Common routines for all of Debbugs ++ ++=head1 SYNOPSIS ++ ++use Debbugs::Common qw(:url :html); ++ ++ ++=head1 DESCRIPTION ++ ++This module is a replacement for the general parts of errorlib.pl. ++subroutines in errorlib.pl will be gradually phased out and replaced ++with equivalent (or better) functionality here. ++ ++=head1 FUNCTIONS ++ ++=cut ++ ++use warnings; use strict; ++use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); ++use base qw(Exporter); ++ ++BEGIN{ ++ $VERSION = 1.00; ++ $DEBUG = 0 unless defined $DEBUG; ++ ++ @EXPORT = (); ++ %EXPORT_TAGS = (util => [qw(getbugcomponent getbuglocation getlocationpath get_hashname), ++ qw(appendfile), ++ ], ++ quit => [qw(quit)], ++ lock => [qw(filelock unfilelock)], ++ ); ++ @EXPORT_OK = (); - Exporter::export_ok_tags(qw(read util)); +++ Exporter::export_ok_tags(qw(lock quit util)); ++ $EXPORT_TAGS{all} = [@EXPORT_OK]; ++} ++ ++#use Debbugs::Config qw(:globals); ++use Debbugs::Config qw(:config); ++use IO::File; ++use Debbugs::MIME qw(decode_rfc1522); ++ ++use Fcntl qw(:flock); ++ ++=head1 UTILITIES ++ ++The following functions are exported by the C<:util> tag ++ ++=head2 getbugcomponent ++ ++ my $file = getbugcomponent($bug_number,$extension,$location) ++ ++Returns the path to the bug file in location C<$location>, bug number ++C<$bugnumber> and extension C<$extension> ++ ++=cut ++ ++sub getbugcomponent { ++ my ($bugnum, $ext, $location) = @_; ++ ++ if (not defined $location) { ++ $location = getbuglocation($bugnum, $ext); ++ # Default to non-archived bugs only for now; CGI scripts want ++ # archived bugs but most of the backend scripts don't. For now, ++ # anything that is prepared to accept archived bugs should call ++ # getbuglocation() directly first. ++ return undef if defined $location and ++ ($location ne 'db' and $location ne 'db-h'); ++ } ++ return undef if not defined $location; ++ my $dir = getlocationpath($location); ++ return undef if not defined $dir; ++ if ($location eq 'db') { ++ return "$dir/$bugnum.$ext"; ++ } else { ++ my $hash = get_hashname($bugnum); ++ return "$dir/$hash/$bugnum.$ext"; ++ } ++} ++ ++=head2 getbuglocation ++ ++ getbuglocation($bug_number,$extension) ++ ++Returns the the location in which a particular bug exists; valid ++locations returned currently are archive, db-h, or db. If the bug does ++not exist, returns undef. ++ ++=cut ++ ++sub getbuglocation { ++ my ($bugnum, $ext) = @_; ++ my $archdir = get_hashname($bugnum); ++ return 'archive' if -r getlocationpath('archive')."/$archdir/$bugnum.$ext"; ++ return 'db-h' if -r getlocationpath('db-h')."/$archdir/$bugnum.$ext"; ++ return 'db' if -r getlocationpath('db')."/$bugnum.$ext"; ++ return undef; ++} ++ ++ ++=head2 getlocationpath ++ ++ getlocationpath($location) ++ ++Returns the path to a specific location ++ ++=cut ++ ++sub getlocationpath { ++ my ($location) = @_; ++ if (defined $location and $location eq 'archive') { ++ return "$config{spool_dir}/archive"; ++ } elsif (defined $location and $location eq 'db') { ++ return "$config{spool_dir}/db"; ++ } else { ++ return "$config{spool_dir}/db-h"; ++ } ++} --BEGIN { -- use Exporter (); -- use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); -- # set the version for version checking -- $VERSION = 1.00; ++=head2 get_hashname -- @ISA = qw(Exporter); -- @EXPORT = qw(&fail &NameToPathHash &sani &quit); -- %EXPORT_TAGS = ( ); # eg: TAG => [ qw!name1 name2! ], ++ get_hashname -- # your exported package globals go here, -- # as well as any optionally exported functions -- @EXPORT_OK = qw(); ++Returns the hash of the bug which is the location within the archive ++ ++=cut ++ ++sub get_hashname { ++ return "" if ( $_[ 0 ] < 0 ); ++ return sprintf "%02d", $_[ 0 ] % 100; ++} ++ ++ ++=head2 appendfile ++ ++ appendfile($file,'data','to','append'); ++ ++Opens a file for appending and writes data to it. ++ ++=cut ++ ++sub appendfile { ++ my $file = shift; ++ if (!open(AP,">>$file")) { ++ print DEBUG "failed open log<\n"; ++ print DEBUG "failed open log err $!<\n"; ++ &quit("opening $file (appendfile): $!"); ++ } ++ print(AP @_) || &quit("writing $file (appendfile): $!"); ++ close(AP) || &quit("closing $file (appendfile): $!"); } --use vars @EXPORT_OK; --use Debbugs::Config qw(%Globals); --use FileHandle; ++=head1 LOCK ++ ++These functions are exported with the :lock tag ++ ++=head2 filelock ++ ++ filelock ++ ++FLOCKs the passed file. Use unfilelock to unlock it. ++ ++=cut ++ ++my @filelocks; + my @cleanups; --my $DEBUG = new FileHandle; -- --sub fail --{ -- print "$_[0]\n"; -- exit 1; --} --sub NameToPathHash --{ --# 12345 -> 5/4/3/12345 --# 12 -> s/2/1/12 -- my $name = $_[0]; -- my $tmp = $name; -- $name =~ /^.*?(.)(.)(.)$/ ; -- if(!defined($1)) { -- $name =~ /^(.*?)(.)(.)$/ ; -- $tmp = "$1$2$3"."s"; ++ ++sub filelock { ++ # NB - NOT COMPATIBLE WITH `with-lock' ++ my ($lockfile) = @_; ++ my ($count,$errors) = @_; ++ $count= 10; $errors= ''; ++ for (;;) { ++ my $fh = eval { ++ my $fh = new IO::File $lockfile,'w' ++ or die "Unable to open $lockfile for writing: $!"; ++ flock($fh,LOCK_EX|LOCK_NB) ++ or die "Unable to lock $lockfile $!"; ++ return $fh; ++ }; ++ if ($@) { ++ $errors .= $@; ++ } ++ if ($fh) { ++ push @filelocks, {fh => $fh, file => $lockfile}; ++ last; ++ } ++ if (--$count <=0) { ++ $errors =~ s/\n+$//; ++ &quit("failed to get lock on $lockfile -- $errors"); ++ } ++ sleep 10; } -- $tmp =~ /^.*?(.)(.)(.)$/ ; -- return "$3/$2/$1/$name"; ++ push(@cleanups,\&unfilelock); } --sub DEBUG --{ -- print $DEBUG $_; ++ ++=head2 unfilelock ++ ++ unfilelock() ++ ++Unlocks the file most recently locked. ++ ++Note that it is not currently possible to unlock a specific file ++locked with filelock. ++ ++=cut ++ ++sub unfilelock { ++ if (@filelocks == 0) { ++ warn "unfilelock called with no active filelocks!\n"; ++ return; ++ } ++ my %fl = %{pop(@filelocks)}; ++ pop(@cleanups); ++ flock($fl{fh},LOCK_UN) ++ or warn "Unable to unlock lockfile $fl{file}: $!"; ++ close($fl{fh}) ++ or warn "Unable to close lockfile $fl{file}: $!"; ++ unlink($fl{file}) ++ or warn "Unable to unlink locfile $fl{file}: $!"; } --sub quit --{ -- DEBUG("quitting >$_[0]<\n"); -- my $u; ++ ++ ++ ++=head1 QUIT ++ ++These functions are exported with the :quit tag. ++ ++=head2 quit ++ ++ quit() ++ ++Exits the program by calling die after running some cleanups. ++ ++This should be replaced with an END handler which runs the cleanups ++instead. (Or possibly a die handler, if the cleanups are important) ++ ++=cut ++ ++sub quit { ++ print DEBUG "quitting >$_[0]<\n"; - local ($u); +++ my ($u); while ($u= $cleanups[$#cleanups]) { &$u; } die "*** $_[0]\n"; } diff --cc Debbugs/Config.pm index 9451ce23,6cf66d83,6cf66d83..7cdbb306 --- a/Debbugs/Config.pm +++ b/Debbugs/Config.pm @@@@ -1,414 -1,192 -1,192 +1,419 @@@@ --package Debbugs::Config; # assumes Some/Module.pm ++package Debbugs::Config; ++ ++=head1 NAME ++ ++Debbugs::Config -- Configuration information for debbugs ++ ++=head1 SYNOPSIS ++ ++ use Debbugs::Config; ++ ++# to get the compatiblity interface ++ ++ use Debbugs::Config qw(:globals); ++ ++=head1 DESCRIPTION ++ ++This module provides configuration variables for all of debbugs. ++ ++=head1 CONFIGURATION FILES ++ ++The default configuration file location is /etc/debbugs/config; this ++configuration file location can be set by modifying the ++DEBBUGS_CONFIG_FILE env variable to point at a different location. ++ ++=cut ++ ++use warnings; use strict; ++use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT $USING_GLOBALS %config); ++use base qw(Exporter); ++ ++BEGIN { ++ # set the version for version checking ++ $VERSION = 1.00; ++ $DEBUG = 0 unless defined $DEBUG; ++ $USING_GLOBALS = 0; ++ ++ @EXPORT = (); ++ %EXPORT_TAGS = (globals => [qw($gEmailDomain $gListDomain $gWebHost $gWebHostBugDir), ++ qw($gWebDomain $gHTMLSuffix $gCGIDomain $gMirrors), ++ qw($gPackagePages $gSubscriptionDomain $gProject $gProjectTitle), ++ qw($gMaintainer $gMaintainerWebpage $gMaintainerEmail $gUnknownMaintainerEmail), ++ qw($gSubmitList $gMaintList $gQuietList $gForwardList), ++ qw($gDoneList $gRequestList $gSubmitterList $gControlList), ++ qw($gSummaryList $gMirrorList $gMailer $gBug), ++ qw($gBugs $gRemoveAge $gSaveOldBugs $gDefaultSeverity), ++ qw($gShowSeverities $gBounceFroms $gConfigDir $gSpoolDir), ++ qw($gIncomingDir $gWebDir $gDocDir $gMaintainerFile), ++ qw($gMaintainerFileOverride $gPseudoDescFile $gPackageSource), +++ qw($gVersionPackagesDir $gVersionIndex $gBinarySourceMap $gSourceBinaryMap), ++ qw(%gSeverityDisplay @gTags @gSeverityList @gStrongSeverities), +++ qw(%gSearchEstraier), ++ ], ++ config => [qw(%config)], ++ ); ++ @EXPORT_OK = (); ++ Exporter::export_ok_tags(qw(globals config)); ++ $EXPORT_TAGS{all} = [@EXPORT_OK]; ++} ++ ++use File::Basename qw(dirname); ++use IO::File; ++use Safe; ++ ++=head1 CONFIGURATION VARIABLES ++ ++=head2 General Configuration ++ ++=over ++ ++=cut ++ ++# read in the files; ++%config = (); ++read_config(exists $ENV{DEBBUGS_CONFIG_FILE}?$ENV{DEBBUGS_CONFIG_FILE}:'/etc/debbugs/config'); ++ ++=item email_domain ++ ++The email domain of the bts ++ ++=cut ++ ++set_default(\%config,'email_domain','bugs.something'); ++ ++=item list_domain ++ ++The list domain of the bts, defaults to the email domain ++ ++=cut ++ ++set_default(\%config,'list_domain',$config{email_domain}); ++ ++=item web_host ++ ++The web host of the bts; defaults to the email domain ++ ++=cut ++ ++set_default(\%config,'web_host',$config{email_domain}); ++ ++=item web_host_bug_dir ++ ++The directory of the web host on which bugs are kept, defaults to C<''> ++ ++=cut ++ ++set_default(\%config,'web_host_bug_dir',''); ++ ++=item web_domain ++ ++Full path of the web domain where bugs are kept, defaults to the ++concatenation of L and L ++ ++=cut ++ ++set_default(\%config,'web_domain',$config{web_host}.'/'.$config{web_host_bug_dir}); ++ ++=item html_suffix ++ ++Suffix of html pages, defaults to .html ++ ++=cut ++ ++set_default(\%config,'html_suffix','.html'); ++ ++=item cgi_domain ++ ++Full path of the web domain where cgi scripts are kept. Defaults to ++the concatentation of L and cgi. ++ ++=cut ++ ++set_default(\%config,'cgi_domain',$config{web_domain}.($config{web_domain}=~m{/$}?'':'/').'cgi'); ++ ++=item mirrors ++ ++List of mirrors [What these mirrors are used for, no one knows.] ++ ++=cut ++ ++ ++set_default(\%config,'mirrors',[]); ++ ++=item package_pages ++ ++Domain where the package pages are kept; links should work in a ++package_pages/foopackage manner. Defaults to undef, which means that ++package links will not be made. ++ ++=cut ++ ++ ++set_default(\%config,'package_pages',undef); ++ ++=item subscription_domain ++ ++Domain where subscriptions to package lists happen ++ ++=cut ++ ++ ++set_default(\%config,'subscription_domain',undef); ++ ++=back --BEGIN --{ use Exporter (); -- use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); -- -- # set the version for version checking -- $VERSION = 1.00; ++=cut -- @ISA = qw(Exporter); -- @EXPORT = qw(%Globals %GTags %Strong %Severity ); -- %EXPORT_TAGS = ( ); # eg: TAG => [ qw!name1 name2! ], -- # your exported package globals go here, -- # as well as any optionally exported functions -- @EXPORT_OK = qw(%Globals %GTags %Severity %Strong &ParseConfigFile &ParseXMLConfigFile); ++=head2 Project Identification ++ ++=over ++ ++=item project ++ ++Name of the project ++ ++=cut ++ ++set_default(\%config,'project','Something'); ++ ++=item project_title ++ ++Name of this install of Debbugs, defaults to "L Debbugs Install" ++ ++=cut ++ ++set_default(\%config,'project_title',"$config{project} Debbugs Install"); ++ ++=item maintainer ++ ++Name of the maintainer of this debbugs install ++ ++=cut ++ ++set_default(\%config,'maintainer','Local DebBugs Owner'); ++ ++=item maintainer_webpage ++ ++Webpage of the maintainer of this install of debbugs ++ ++=cut ++ ++set_default(\%config,'maintainer_webpage',"$config{web_domain}/~owner"); ++ ++=item maintainer_email ++ ++Email address of the maintainer of this Debbugs install ++ ++=cut ++ ++set_default(\%config,'maintainer_email','root@'.$config{email_domain}); ++ ++=item unknown_maintainer_email ++ ++Email address where packages with an unknown maintainer will be sent ++ ++=cut ++ ++set_default(\%config,'unknown_maintainer_email',$config{maintainer_email}); ++ ++=head2 BTS Mailing Lists ++ ++ ++=over ++ ++=item submit_list ++ ++=item maint_list ++ ++=item forward_list ++ ++=item done_list ++ ++=item request_list ++ ++=item submitter_list ++ ++=item control_list ++ ++=item summary_list ++ ++=item mirror_list ++ ++=back ++ ++=cut ++ ++set_default(\%config, 'submit_list', 'bug-submit-list'); ++set_default(\%config, 'maint_list', 'bug-maint-list'); ++set_default(\%config, 'quiet_list', 'bug-quiet-list'); ++set_default(\%config, 'forward_list', 'bug-forward-list'); ++set_default(\%config, 'done_list', 'bug-done-list'); ++set_default(\%config, 'request_list', 'bug-request-list'); ++set_default(\%config,'submitter_list','bug-submitter-list'); ++set_default(\%config, 'control_list', 'bug-control-list'); ++set_default(\%config, 'summary_list', 'bug-summary-list'); ++set_default(\%config, 'mirror_list', 'bug-mirror-list'); ++ ++=head2 Misc Options ++ ++=cut ++ ++set_default(\%config,'mailer','exim'); ++set_default(\%config,'bug','bug'); ++set_default(\%config,'bugs','bugs'); ++set_default(\%config,'remove_age',28); ++ ++set_default(\%config,'save_old_bugs',1); ++ ++set_default(\%config,'default_severity','normal'); ++set_default(\%config,'show_severities','critical, grave, normal, minor, wishlist'); ++set_default(\%config,'strong_severities',[qw(critical grave)]); ++set_default(\%config,'severity_list',[qw(critical grave normal wishlist)]); ++set_default(\%config,'severity_display',{critical => "Critical $config{bugs}", ++ grave => "Grave $config{bugs}", ++ normal => "Normal $config{bugs}", ++ wishlist => "Wishlist $config{bugs}", ++ }); ++ ++set_default(\%config,'tags',[qw(patch wontfix moreinfo unreproducible fixed stable)]); ++ ++set_default(\%config,'bounce_froms','^mailer|^da?emon|^post.*mast|^root|^wpuser|^mmdf|^smt.*|'. ++ '^mrgate|^vmmail|^mail.*system|^uucp|-maiser-|^mal\@|'. ++ '^mail.*agent|^tcpmail|^bitmail|^mailman'); ++ ++set_default(\%config,'config_dir',dirname(exists $ENV{DEBBUGS_CONFIG_FILE}?$ENV{DEBBUGS_CONFIG_FILE}:'/etc/debbugs/config')); ++set_default(\%config,'spool_dir','/var/lib/debbugs/spool'); ++set_default(\%config,'incoming_dir','incoming'); ++set_default(\%config,'web_dir','/var/lib/debbugs/www'); ++set_default(\%config,'doc_dir','/var/lib/debbugs/www/txt'); ++ ++set_default(\%config,'maintainer_file',$config{config_dir}.'/Maintainers'); ++set_default(\%config,'maintainer_file_override',$config{config_dir}.'/Maintainers.override'); ++set_default(\%config,'pseduo_desc_file',$config{config_dir}.'/pseudo-packages.description'); ++set_default(\%config,'package_source',$config{config_dir}.'/indices/sources'); ++ +++set_default(\%config,'version_packages_dir',$config{spool_dir}.'/../versions/pkg'); +++#set_default(\%config,'version_packages_dir',$config{spool_dir}'/../versions/pkg'); +++ ++ ++sub read_config{ ++ my ($conf_file) = @_; ++ # first, figure out what type of file we're reading in. ++ my $fh = new IO::File $conf_file,'r' ++ or die "Unable to open configuration file $conf_file for reading: $!"; ++ # A new version configuration file must have a comment as its first line ++ my $first_line = <$fh>; ++ my ($version) = $first_line =~ /VERSION:\s*(\d+)/i; ++ if (defined $version) { ++ if ($version == 1) { ++ # Do something here; ++ die "Version 1 configuration files not implemented yet"; ++ } ++ else { ++ die "Version $version configuration files are not supported"; ++ } ++ } ++ else { ++ # Ugh. Old configuration file ++ # What we do here is we create a new Safe compartment ++ # so fucked up crap in the config file doesn't sink us. ++ my $cpt = new Safe or die "Unable to create safe compartment"; ++ # perldoc Opcode; for details - $cpt->permit('require'); +++ $cpt->permit('require',':filesys_read','entereval','caller','pack','unpack','dofile'); ++ $cpt->reval(q($gMaintainerFile = 'FOOOO')); ++ $cpt->reval(qq(require '$conf_file';)); ++ die "Error in configuration file: $@" if $@; ++ # Now what we do is check out the contents of %EXPORT_TAGS to see exactly which variables ++ # we want to glob in from the configuration file ++ for my $variable (@{$EXPORT_TAGS{globals}}) { ++ my ($hash_name,$glob_name,$glob_type) = __convert_name($variable); ++ my $var_glob = $cpt->varglob($glob_name); ++ my $value; #= $cpt->reval("return $variable"); ++ #print STDERR $value,qq(\n); ++ if (defined $var_glob) {{ ++ no strict 'refs'; ++ if ($glob_type eq '%') { ++ $value = {%{*{$var_glob}}}; ++ } ++ elsif ($glob_type eq '@') { ++ $value = [@{*{$var_glob}}]; ++ } ++ else { ++ $value = ${*{$var_glob}}; ++ } ++ # We punt here, because we can't tell if the value was ++ # defined intentionally, or if it was just left alone; ++ # this tries to set sane defaults. ++ set_default(\%config,$hash_name,$value) if defined $value; ++ }} ++ } ++ } } --use vars @EXPORT_OK; --use Debbugs::Common; --use Debbugs::Email; -- --# initialize package globals, first exported ones --%Severity = (); --%Strong = (); --$Severity{ 'Text' } = (); --%GTags = (); --%Globals = ( "debug" => 0, -- "verbose" => 0, -- "quiet" => 0, -- ##### domains -- "email-domain" => "bugs.domain.com", -- "list-domain" => "lists.domain.com", -- "web-domain" => "web.domain.com", -- "cgi-domain" => "cgi.domain.com", -- ##### identification -- "project-short" => "debbugs", -- "project-long" => "Debbugs Test Project", -- "owner-name" => "Fred Flintstone", -- "owner-email" => "owner\@bugs.domain.com", -- ##### directories -- "work-dir" => "/var/lib/debbugs/spool", -- "spool-dir" => "/var/lib/debbugs/spool/incoming", -- "www-dir" => "/var/lib/debbugs/www", -- "doc-dir" => "/var/lib/debbugs/www/txt", -- ##### files -- "maintainer-file" => "/etc/debbugs/Maintainers", -- "pseudo-description" => "/etc/debbugs/pseudo-packages.description"); -- --my %ConfigMap = ( -- "Email Domain" => "email-domain", -- "List Domain" => "list-domain", -- "Web Domain" => "web-domain", -- "CGI Domain" => "cgi-domain", -- "Short Name" => "project-short", -- "Long Name" => "project-long", -- "Owner Name" => "owner-name", -- "Owner Email" => "owner-email", -- "Errors Email" => "errors-email", -- "Owner Webpage" => "owner-webpage", -- "Spool Dir" => "spool-dir", -- "Work Dir" => "work-dir", -- "Web Dir" => "www-dir", -- "Doc Dir" => "doc-dir", -- "Template Dir" => "template-dir", -- "Not-Don-Con" => "not-don-con", -- "Maintainer File" => "maintainer-file", -- "Pseudo Description File" => "pseudo-description", -- "Submit List" => "submit-list", -- "Maint List" => "maint-list", -- "Quiet List" => "quiet-list", -- "Forwarded List" => "forwarded-list", -- "Done List" => "done-list", -- "Request List" => "request-list", -- "Submitter List" => "submitter-list", -- "Control List" => "control-list", -- "Summary List" => "summary-list", -- "Mirror List" => "mirror-list", -- "Mailer" => "mailer", -- "Singular Term" => "singluar", -- "Plural Term" => "plural", -- "Expire Age" => "expire-age", -- "Save Expired Bugs" => "save-expired", -- "Mirrors" => "mirrors", -- "Default Severity" => "default-severity", -- "Normal Severity" => "normal-severity", -- ); -- --my %GTagsMap = ( -- "email-domain" => "EMAIL_DOMAIN", -- "list-domain" => "LIST_DOMAIN", -- "web-domain" => "WEB_DOMAIN", -- "cgi-domain" => "CGI_DOMAIN", -- "project-short" => "SHORT_NAME", -- "project-long" => "LONG_NAME", -- "owner-name" => "OWNER_NAME", -- "owner-email" => "OWNER_EMAIL", -- "submit-list" => "SUBMIT_LIST", -- "quiet-list" => "QUIET_LIST", -- "forwarded-list" => "FORWARDED_LIST", -- "done-list" => "DONE_LIST", -- "request-list" => "REQUEST_LIST", -- "submitter-list" => "SUBMITTER_LIST", -- "control-list" => "CONTROL_LIST", -- "summary-list" => "SUMMARY_LIST", -- "mirror-list" => "MIRROR_LIST", -- "mirrors" => "MIRRORS" -- ); -- --sub strip --{ my $string = $_[0]; -- chop $string while $string =~ /\s$/; -- return $string; ++sub __convert_name{ ++ my ($variable) = @_; ++ my $hash_name = $variable; ++ $hash_name =~ s/^([\$\%\@])g//; ++ my $glob_type = $1; ++ my $glob_name = 'g'.$hash_name; ++ $hash_name =~ s/^([A-Z]+)/lc($1)/e; ++ $hash_name =~ s/([A-Z]+)/'_'.lc($1)/ge; ++ return $hash_name unless wantarray; ++ return ($hash_name,$glob_name,$glob_type); } --############################################################################# --# Read Config File and parse --############################################################################# --sub ParseConfigFile --{ my $configfile = $_[0]; -- my @config; -- my $votetitle = ''; -- my $ballottype = ''; -- -- #load config file -- print "V: Loading Config File\n" if $Globals{ "verbose" }; -- open(CONFIG,$configfile) or &fail( "E: Unable to open `$configfile'" ); -- @config = ; -- close CONFIG; -- -- #parse config file -- print "V: Parsing Config File\n" if $Globals{ "verbose" }; -- print "D3: Parse Config:\n@config\n" if $Globals{ 'debug' } > 2; -- print "D1: Configuration\n" if $Globals{ 'debug' }; -- -- for( my $i=0; $i<=$#config; $i++) -- { $_ = $config[$i]; -- chop $_; -- next unless length $_; -- next if /^#/; -- -- if ( /^([^:=]*)\s*[:=]\s*([^#]*)/i ) { -- my $key = strip( $1 ); -- my $value = strip( $2 ); -- $value = "" if(!defined($value)); -- if ( $key =~ /Severity\s+#*(\d+)\s*(.*)/ ) { -- my $options = $2; -- my $severity = $1; -- if( $options =~ /\btext\b/ ) { -- $Severity{ 'Text' }{ $severity } = $value; -- print "D2: (config) Severity $severity text = $value\n" if $Globals{ 'debug' } > 1; -- } else { -- $Severity{ $1 } = $value; -- print "D2: (config) Severity $severity = $value" if $Globals{ 'debug' } > 1; -- if( $options =~ /\bdefault\b/ ) { -- $Globals{ "default-severity" } = $severity; -- print ", default" if $Globals{ 'debug' } > 1; -- } -- if( $options =~ /\bstrong\b/ ) { -- $Strong{ $severity } = 1; -- print ", strong" if $Globals{ 'debug' } > 1; -- } -- print "\n" if $Globals{ 'debug' } > 1; -- } -- next; -- } else { -- my $map = $ConfigMap{$key}; -- if(defined($map)) { -- $Globals{ $map } = $value; -- print "$key = '$value'" if $Globals{ 'debug' } > 1; -- my $gtag = $GTagsMap{ $map }; -- if(defined($gtag)) { -- $GTags{ $gtag } = $value; -- print "GTag = '$gtag'" if $Globals{ 'debug' } > 1; -- } -- print "\n" if $Globals{ 'debug' } > 1; -- next; -- } else { -- print "$key\n"; -- } -- -- } -- } -- print "Unknown line in config!($_)\n"; -- next; -- } -- return @config; ++# set_default ++ ++# sets the configuration hash to the default value if it's not set, ++# otherwise doesn't do anything ++# If $USING_GLOBALS, then sets an appropriate global. ++ ++sub set_default{ ++ my ($config,$option,$value) = @_; ++ # update the configuration value ++ if (not $USING_GLOBALS and not exists $config{$option}) { ++ $config{$option} = $value; ++ } ++ else { ++ # Need to check if a value has already been set in a global ++ } ++ if ($USING_GLOBALS) {{ ++ # fix up the variable name ++ my $varname = 'g'.join('',map {ucfirst $_} $option); ++ # Fix stupid HTML names ++ $varname =~ s/Html/HTML/; ++ no strict 'refs'; ++ my $ref = ref $config{$option} || 'SCALAR'; ++ *{"Debbugs::Config::${varname}"} = $config{$option}; ++ }} ++} ++ ++ ++### import magick ++ ++# All we care about here is whether we've been called with the globals option; ++# if so, then we need to export some symbols back up; otherwise we call exporter. ++ ++sub import { ++ if (grep $_ eq ':globals', @_) { ++ $USING_GLOBALS=1; ++ for my $variable (@{$EXPORT_TAGS{globals}}) { ++ my $tmp = $variable; ++ no strict 'refs'; ++ # Yes, I don't care if these are only used once ++ no warnings 'once'; ++ # No, it doesn't bother me that I'm assigning an undefined value to a typeglob ++ no warnings 'misc'; ++ my ($hash_name,$glob_name,$glob_type) = __convert_name($variable); ++ $tmp =~ s/^[\%\$\@]//; ++ *{"Debbugs::Config::${tmp}"} = ref($config{$hash_name})?$config{$hash_name}:\$config{$hash_name}; ++ } ++ } ++ Debbugs::Config->export_to_level(1,@_); } --END { } # module clean-up code here (global destructor) ++ ++1; diff --cc Debbugs/Estraier.pm index 86963ee3,00000000,00000000..2aa12fba mode 100644,000000,000000..100644 --- a/Debbugs/Estraier.pm +++ b/Debbugs/Estraier.pm @@@@ -1,140 -1,0 -1,0 +1,170 @@@@ ++ ++package Debbugs::Estraier; ++ ++=head1 NAME ++ ++Debbugs::Estraier -- Routines for interfacing bugs to HyperEstraier ++ ++=head1 SYNOPSIS ++ ++use Debbugs::Estraier; ++ ++ ++=head1 DESCRIPTION ++ ++ ++=head1 BUGS ++ ++None known. ++ ++=cut ++ ++use warnings; ++use strict; ++use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); ++use base qw(Exporter); ++use Debbugs::Log; ++#use Params::Validate; ++use Search::Estraier; ++use Date::Manip; ++use Debbugs::Common qw(getbuglocation getbugcomponent readbug); ++ ++ ++BEGIN{ ++ ($VERSION) = q$Revision: 1.3 $ =~ /^Revision:\s+([^\s+])/; ++ $DEBUG = 0 unless defined $DEBUG; ++ ++ @EXPORT = (); ++ %EXPORT_TAGS = (add => [qw(add_bug_log add_bug_message)], ++ ); ++ @EXPORT_OK = (); ++ Exporter::export_ok_tags(qw(add)); ++ $EXPORT_TAGS{all} = [@EXPORT_OK]; ++} ++ ++ ++sub add_bug_log{ ++ my ($est,$bug_num) = @_; ++ ++ # We want to read the entire bug log, pulling out individual ++ # messages, and shooting them through hyper estraier ++ ++ my $location = getbuglocation($bug_num,'log'); ++ my $bug_log = getbugcomponent($bug_num,'log',$location); ++ my $log_fh = new IO::File $bug_log, 'r' or ++ die "Unable to open bug log $bug_log for reading: $!"; ++ ++ my $log = Debbugs::Log->new($log_fh) or ++ die "Debbugs::Log was unable to be initialized"; ++ ++ my %seen_msg_ids; ++ my $msg_num=0; ++ my $status = {}; ++ if (my $location = getbuglocation($bug_num,'summary')) { ++ $status = readbug($bug_num,$location); ++ } ++ while (my $record = $log->read_record()) { ++ $msg_num++; ++ next unless $record->{type} eq 'incoming-recv'; ++ my ($msg_id) = $record->{text} =~ /^Message-Id:\s+<(.+)>/im; ++ next if defined $msg_id and exists $seen_msg_ids{$msg_id}; ++ $seen_msg_ids{$msg_id} = 1 if defined $msg_id; ++ next if $msg_id =~ /handler\..+\.ack(?:info)?\@/; ++ add_bug_message($est,$record->{text},$bug_num,$msg_num,$status) ++ } +++ return $msg_num; +++} +++ +++=head2 remove_old_message +++ +++ remove_old_message($est,300000,50); +++ +++Removes all messages which are no longer in the log +++ +++=cut +++ +++sub remove_old_messages{ +++ my ($est,$bug_num,$max_message) = @_; +++ # remove records which are no longer present in the log (uri > $msg_num) +++ my $cond = new Search::Estraier::Condition; +++ $cond->add_attr('@uri STRBW '.$bug_num.'/'); +++ $cond->set_max(50); +++ my $skip; +++ my $nres; +++ while ($nres = $est->search($cond,0) and $nres->doc_num > 0){ +++ for my $rdoc (map {$nres->get_doc($_)} 0..($nres->doc_num-1)) { +++ my $uri = $rdoc->uri; +++ my ($this_message) = $uri =~ m{/(\d+)$}; +++ next unless $this_message > $max_message; +++ $est->out_doc_by_uri($uri); +++ } +++ last unless $nres->doc_num >= $cond->max; +++ $cond->set_skip($cond->skip+$cond->max); +++ } +++ ++} ++ ++sub add_bug_message{ ++ my ($est,$bug_message,$bug_num, ++ $msg_num,$status) = @_; ++ ++ my $doc; ++ my $uri = "$bug_num/$msg_num"; ++ $doc = $est->get_doc_by_uri($uri); ++ $doc = new Search::Estraier::Document if not defined $doc; ++ $doc->add_text($bug_message); ++ ++ # * @id : the ID number determined automatically when the document is registered. ++ # * @uri : the location of a document which any document should have. ++ # * @digest : the message digest calculated automatically when the document is registered. ++ # * @cdate : the creation date. ++ # * @mdate : the last modification date. ++ # * @adate : the last access date. ++ # * @title : the title used as a headline in the search result. ++ # * @author : the author. ++ # * @type : the media type. ++ # * @lang : the language. ++ # * @genre : the genre. ++ # * @size : the size. ++ # * @weight : the scoring weight. ++ # * @misc : miscellaneous information. ++ my @attr = qw(status subject date submitter package tags severity); ++ # parse the date ++ my ($date) = $bug_message =~ /^Date:\s+(.+?)\s*$/mi; ++ $doc->add_attr('@cdate' => $date); ++ # parse the title ++ my ($subject) = $bug_message =~ /^Subject:\s+(.+?)\s*$/mi; ++ $doc->add_attr('@title' => $subject); ++ # parse the author ++ my ($author) = $bug_message =~ /^From:\s+(.+?)\s*$/mi; ++ $doc->add_attr('@author' => $author); ++ # create the uri ++ $doc->add_attr('@uri' => $uri); ++ foreach my $attr (@attr) { ++ $doc->add_attr($attr => $status->{$attr}); ++ } ++ print STDERR "adding $uri\n" if $DEBUG; ++ # Try a bit harder if estraier is returning timeouts ++ my $attempt = 5; ++ while ($attempt > 0) { ++ $est->put_doc($doc) and last; ++ my $status = $est->status; ++ $attempt--; ++ print STDERR "Failed to add $uri\n".$status."\n"; ++ last unless $status =~ /^5/; ++ sleep 20; ++ } ++ ++} ++ ++ ++1; ++ ++ ++__END__ ++ ++ ++ ++ ++ ++ diff --cc Debbugs/Packages.pm index 9ea1f1c9,5dabd955,4ae58a5d..00eda549 --- a/Debbugs/Packages.pm +++ b/Debbugs/Packages.pm @@@@ -11,15 -14,9 -14,9 +11,15 @@@@ use vars qw($VERSION @EXPORT_OK %EXPORT BEGIN { $VERSION = 1.00; -- @ISA = qw(Exporter); -- @EXPORT = qw(getpkgsrc getpkgcomponent getsrcpkgs -- binarytosource sourcetobinary); ++ @EXPORT = (); - %EXPORT_TAGS = (versions => [qw(getverions)], +++ %EXPORT_TAGS = (versions => [qw(getversions)], ++ mapping => [qw(getpkgsrc getpkgcomponent getsrcpkgs), ++ qw(binarytosource sourcetobinary) ++ ], ++ ); ++ @EXPORT_OK = (); ++ Exporter::export_ok_tags(qw(versions mapping)); ++ $EXPORT_TAGS{all} = [@EXPORT_OK]; } use Fcntl qw(O_RDONLY); diff --cc Debbugs/SOAP/Status.pm index 00000000,00000000,00000000..b452eb07 new file mode 100644 --- /dev/null +++ b/Debbugs/SOAP/Status.pm @@@@ -1,0 -1,0 -1,0 +1,22 @@@@ +++package Debbugs::SOAP::Status; +++ +++# This is a hack that must be removed +++require '/home/don/projects/debbugs/source/cgi/common.pl'; +++#use Debbugs::Status qw(getbugstatus); +++ +++sub get_status { +++ my ($class, @bugs) = @_; +++ @bugs = map {ref($_)?@{$_}:$_} @bugs; +++ +++ my %s; +++ foreach (@bugs) { +++ my $hash = getbugstatus($_); +++ if (scalar(%{$hash}) > 0) { +++ $s{$_} = $hash; +++ } +++ } +++ +++ return \%s; +++} +++ +++1; diff --cc Debbugs/Status.pm index de0d5cc6,00000000,00000000..81733318 mode 100644,000000,000000..100644 --- a/Debbugs/Status.pm +++ b/Debbugs/Status.pm @@@@ -1,583 -1,0 -1,0 +1,584 @@@@ ++ ++package Debbugs::Status; ++ ++=head1 NAME ++ ++Debbugs::Status -- Routines for dealing with summary and status files ++ ++=head1 SYNOPSIS ++ ++use Debbugs::Status; ++ ++ ++=head1 DESCRIPTION ++ ++This module is a replacement for the parts of errorlib.pl which write ++and read status and summary files. ++ ++It also contains generic routines for returning information about the ++status of a particular bug ++ ++=head1 FUNCTIONS ++ ++=cut ++ ++use warnings; ++use strict; ++use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); ++use base qw(Exporter); ++ ++use Params::Validate qw(validate_with :types); ++use Debbugs::Common qw(:util :lock); ++use Debbugs::Config qw(:config); +++use Debbugs::MIME qw(decode_rfc1522 encode_rfc1522); +++ ++ ++BEGIN{ ++ $VERSION = 1.00; ++ $DEBUG = 0 unless defined $DEBUG; ++ ++ @EXPORT = (); - %EXPORT_TAGS = (status => [qw(splitpackages getbugstatus)], +++ %EXPORT_TAGS = (status => [qw(splitpackages)], ++ read => [qw(readbug lockreadbug)], ++ write => [qw(writebug makestatus unlockwritebug)], ++ versions => [qw(addfoundversion addfixedversion), - qw(), ++ ], ++ ); ++ @EXPORT_OK = (); - Exporter::export_ok_tags(qw(splitpackages)); +++ Exporter::export_ok_tags(qw(status read write versions)); ++ $EXPORT_TAGS{all} = [@EXPORT_OK]; ++} ++ ++ ++=head2 readbug ++ ++ readbug($bug_number,$location) ++ ++Reads a summary file from the archive given a bug number and a bug ++location. Valid locations are those understood by L ++ ++=cut ++ ++ ++my %fields = (originator => 'submitter', ++ date => 'date', ++ subject => 'subject', ++ msgid => 'message-id', ++ 'package' => 'package', ++ keywords => 'tags', ++ done => 'done', ++ forwarded => 'forwarded-to', ++ mergedwith => 'merged-with', ++ severity => 'severity', ++ owner => 'owner', ++ found_versions => 'found-in', ++ found_date => 'found-date', ++ fixed_versions => 'fixed-in', ++ fixed_date => 'fixed-date', ++ blocks => 'blocks', ++ blockedby => 'blocked-by', ++ ); ++ ++# Fields which need to be RFC1522-decoded in format versions earlier than 3. ++my @rfc1522_fields = qw(originator subject done forwarded owner); ++ ++=head2 readbug ++ ++ readbug($bug_num,$location); ++ readbug($bug_num) ++ ++ ++Retreives the information from the summary files for a particular bug ++number. If location is not specified, getbuglocation is called to fill ++it in. ++ ++=cut ++ ++sub readbug { ++ my ($lref, $location) = @_; ++ if (not defined $location) { ++ $location = getbuglocation($lref,'summary'); ++ return undef if not defined $location; ++ } ++ my $status = getbugcomponent($lref, 'summary', $location); ++ return undef unless defined $status; ++ my $status_fh = new IO::File $status, 'r' or ++ warn "Unable to open $status for reading: $!" and return undef; ++ ++ my %data; ++ my @lines; ++ my $version = 2; ++ local $_; ++ ++ while (<$status_fh>) { ++ chomp; ++ push @lines, $_; ++ $version = $1 if /^Format-Version: ([0-9]+)/i; ++ } ++ ++ # Version 3 is the latest format version currently supported. ++ return undef if $version > 3; ++ ++ my %namemap = reverse %fields; ++ for my $line (@lines) { ++ if ($line =~ /(\S+?): (.*)/) { ++ my ($name, $value) = (lc $1, $2); ++ $data{$namemap{$name}} = $value if exists $namemap{$name}; ++ } ++ } ++ for my $field (keys %fields) { ++ $data{$field} = '' unless exists $data{$field}; ++ } ++ ++ $data{severity} = $config{default_severity} if $data{severity} eq ''; ++ for my $field (qw(found_versions fixed_versions found_date fixed_date)) { ++ $data{$field} = [split ' ', $data{$field}]; ++ } ++ for my $field (qw(found fixed)) { - $data{$field}{@{$data{${field}_versions}}} = - ('') x (@{$data{${field}_date}} - @{$data{${field}_versions}}), - @{$data{${field}_date}}; +++ @{$data{$field}}{@{$data{"${field}_versions"}}} = +++ (('') x (@{$data{"${field}_date"}} - @{$data{"${field}_versions"}}), +++ @{$data{"${field}_date"}}); ++ } ++ ++ if ($version < 3) { ++ for my $field (@rfc1522_fields) { ++ $data{$field} = decode_rfc1522($data{$field}); ++ } ++ } ++ ++ return \%data; ++} ++ ++=head2 lockreadbug ++ ++ lockreadbug($bug_num,$location) ++ ++Performs a filelock, then reads the bug; the bug is unlocked if the ++return is undefined, otherwise, you need to call unfilelock or ++unlockwritebug. ++ ++See readbug above for information on what this returns ++ ++=cut ++ ++sub lockreadbug { - local ($lref, $location) = @_; +++ my ($lref, $location) = @_; ++ &filelock("lock/$lref"); ++ my $data = readbug($lref, $location); ++ &unfilelock unless defined $data; ++ return $data; ++} ++ ++my @v1fieldorder = qw(originator date subject msgid package ++ keywords done forwarded mergedwith severity); ++ ++=head2 makestatus ++ ++ my $content = makestatus($status,$version) ++ my $content = makestatus($status); ++ ++Creates the content for a status file based on the $status hashref ++passed. ++ ++Really only useful for writebug ++ ++Currently defaults to version 2 (non-encoded rfc1522 names) but will ++eventually default to version 3. If you care, you should specify a ++version. ++ ++=cut ++ ++sub makestatus { ++ my ($data,$version) = @_; ++ $version = 2 unless defined $version; ++ ++ my $contents = ''; ++ ++ my %newdata = %$data; ++ for my $field (qw(found fixed)) { - if (exists $data{$field}) { - $data{"${field}_date"} = - [map {$data{$field}{$_}||''} keys %{$data{$field}}]; +++ if (exists $newdata{$field}) { +++ $newdata{"${field}_date"} = +++ [map {$newdata{$field}{$_}||''} keys %{$newdata{$field}}]; ++ } ++ } ++ ++ for my $field (qw(found_versions fixed_versions found_date fixed_date)) { ++ $newdata{$field} = [split ' ', $newdata{$field}]; ++ } ++ ++ if ($version < 3) { ++ for my $field (@rfc1522_fields) { ++ $newdata{$field} = encode_rfc1522($newdata{$field}); ++ } ++ } ++ ++ if ($version == 1) { ++ for my $field (@v1fieldorder) { ++ if (exists $newdata{$field}) { ++ $contents .= "$newdata{$field}\n"; ++ } else { ++ $contents .= "\n"; ++ } ++ } ++ } elsif ($version == 2 or $version == 3) { ++ # Version 2 or 3. Add a file format version number for the sake of ++ # further extensibility in the future. ++ $contents .= "Format-Version: $version\n"; ++ for my $field (keys %fields) { ++ if (exists $newdata{$field} and $newdata{$field} ne '') { ++ # Output field names in proper case, e.g. 'Merged-With'. ++ my $properfield = $fields{$field}; ++ $properfield =~ s/(?:^|(?<=-))([a-z])/\u$1/g; ++ $contents .= "$properfield: $newdata{$field}\n"; ++ } ++ } ++ } ++ ++ return $contents; ++} ++ ++=head2 writebug ++ ++ writebug($bug_num,$status,$location,$minversion,$disablebughook) ++ ++Writes the bug status and summary files out. ++ ++Skips writting out a status file if minversion is 2 ++ ++Does not call bughook if disablebughook is true. ++ ++=cut ++ ++sub writebug { ++ my ($ref, $data, $location, $minversion, $disablebughook) = @_; ++ my $change; ++ ++ my %outputs = (1 => 'status', 2 => 'summary'); ++ for my $version (keys %outputs) { ++ next if defined $minversion and $version < $minversion; ++ my $status = getbugcomponent($ref, $outputs{$version}, $location); ++ &quit("can't find location for $ref") unless defined $status; ++ open(S,"> $status.new") || &quit("opening $status.new: $!"); ++ print(S makestatus($data, $version)) || ++ &quit("writing $status.new: $!"); ++ close(S) || &quit("closing $status.new: $!"); ++ if (-e $status) { ++ $change = 'change'; ++ } else { ++ $change = 'new'; ++ } ++ rename("$status.new",$status) || &quit("installing new $status: $!"); ++ } ++ ++ # $disablebughook is a bit of a hack to let format migration scripts use ++ # this function rather than having to duplicate it themselves. ++ &bughook($change,$ref,$data) unless $disablebughook; ++} ++ ++=head2 unlockwritebug ++ ++ unlockwritebug($bug_num,$status,$location,$minversion,$disablebughook); ++ ++Writes a bug, then calls unfilelock; see writebug for what these ++options mean. ++ ++=cut ++ ++sub unlockwritebug { ++ writebug(@_); ++ &unfilelock; ++} ++ ++=head1 VERSIONS ++ ++The following functions are exported with the :versions tag ++ ++=head2 addfoundversions ++ ++ addfoundversions($status,$package,$version,$isbinary); ++ ++ ++ ++=cut ++ ++ ++sub addfoundversions { ++ my $data = shift; ++ my $package = shift; ++ my $version = shift; ++ my $isbinary = shift; ++ return unless defined $version; ++ undef $package if $package =~ m[(?:\s|/)]; ++ my $source = $package; ++ ++ if (defined $package and $isbinary) { ++ my @srcinfo = binarytosource($package, $version, undef); ++ if (@srcinfo) { ++ # We know the source package(s). Use a fully-qualified version. ++ addfoundversions($data, $_->[0], $_->[1], '') foreach @srcinfo; ++ return; ++ } ++ # Otherwise, an unqualified version will have to do. ++ undef $source; ++ } ++ ++ # Strip off various kinds of brain-damage. ++ $version =~ s/;.*//; ++ $version =~ s/ *\(.*\)//; ++ $version =~ s/ +[A-Za-z].*//; ++ ++ foreach my $ver (split /[,\s]+/, $version) { ++ my $sver = defined($source) ? "$source/$ver" : ''; ++ unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{found_versions}}) { ++ push @{$data->{found_versions}}, defined($source) ? $sver : $ver; ++ } ++ @{$data->{fixed_versions}} = ++ grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}}; ++ } ++} ++ ++sub removefoundversions { ++ my $data = shift; ++ my $package = shift; ++ my $version = shift; ++ my $isbinary = shift; ++ return unless defined $version; ++ undef $package if $package =~ m[(?:\s|/)]; ++ my $source = $package; ++ ++ if (defined $package and $isbinary) { ++ my @srcinfo = binarytosource($package, $version, undef); ++ if (@srcinfo) { ++ # We know the source package(s). Use a fully-qualified version. ++ removefoundversions($data, $_->[0], $_->[1], '') foreach @srcinfo; ++ return; ++ } ++ # Otherwise, an unqualified version will have to do. ++ undef $source; ++ } ++ ++ foreach my $ver (split /[,\s]+/, $version) { ++ my $sver = defined($source) ? "$source/$ver" : ''; ++ @{$data->{found_versions}} = ++ grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}}; ++ } ++} ++ ++sub addfixedversions { ++ my $data = shift; ++ my $package = shift; ++ my $version = shift; ++ my $isbinary = shift; ++ return unless defined $version; ++ undef $package if $package =~ m[(?:\s|/)]; ++ my $source = $package; ++ ++ if (defined $package and $isbinary) { ++ my @srcinfo = binarytosource($package, $version, undef); ++ if (@srcinfo) { ++ # We know the source package(s). Use a fully-qualified version. ++ addfixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo; ++ return; ++ } ++ # Otherwise, an unqualified version will have to do. ++ undef $source; ++ } ++ ++ # Strip off various kinds of brain-damage. ++ $version =~ s/;.*//; ++ $version =~ s/ *\(.*\)//; ++ $version =~ s/ +[A-Za-z].*//; ++ ++ foreach my $ver (split /[,\s]+/, $version) { ++ my $sver = defined($source) ? "$source/$ver" : ''; ++ unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{fixed_versions}}) { ++ push @{$data->{fixed_versions}}, defined($source) ? $sver : $ver; ++ } ++ @{$data->{found_versions}} = ++ grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}}; ++ } ++} ++ ++sub removefixedversions { ++ my $data = shift; ++ my $package = shift; ++ my $version = shift; ++ my $isbinary = shift; ++ return unless defined $version; ++ undef $package if $package =~ m[(?:\s|/)]; ++ my $source = $package; ++ ++ if (defined $package and $isbinary) { ++ my @srcinfo = binarytosource($package, $version, undef); ++ if (@srcinfo) { ++ # We know the source package(s). Use a fully-qualified version. ++ removefixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo; ++ return; ++ } ++ # Otherwise, an unqualified version will have to do. ++ undef $source; ++ } ++ ++ foreach my $ver (split /[,\s]+/, $version) { ++ my $sver = defined($source) ? "$source/$ver" : ''; ++ @{$data->{fixed_versions}} = ++ grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}}; ++ } ++} ++ ++ ++ ++=head2 splitpackages ++ ++ splitpackages($pkgs) ++ ++Split a package string from the status file into a list of package names. ++ ++=cut ++ ++sub splitpackages { ++ my $pkgs = shift; ++ return unless defined $pkgs; ++ return map lc, split /[ \t?,()]+/, $pkgs; ++} ++ ++ ++=head2 bug_archiveable ++ ++ bug_archiveable(ref => $bug_num); ++ ++Options ++ ++=over ++ ++=item ref -- bug number (required) ++ ++=item status -- Status hashref (optional) ++ ++=item version -- Debbugs::Version information (optional) ++ ++=item days_until -- return days until the bug can be archived ++ ++=back ++ ++Returns 1 if the bug can be archived ++Returns 0 if the bug cannot be archived ++ ++If days_until is true, returns the number of days until the bug can be ++archived, -1 if it cannot be archived. ++ ++=cut ++ ++sub bug_archiveable{ ++ my %param = validate_with(params => \@_, ++ spec => {ref => {type => SCALAR, ++ regex => qr/^\d+$/, ++ }, ++ status => {type => HASHREF, ++ optional => 1, ++ }, ++ version => {type => HASHREF, ++ optional => 1, ++ }, ++ days_until => {type => BOOLEAN, ++ default => 0, ++ }, ++ }, ++ ); ++ # read the status information ++ # read the version information ++ # Bugs can be archived if they are ++ # 1. Closed ++ # 2. Fixed in unstable if tagged unstable ++ # 3. Fixed in stable if tagged stable ++ # 4. Fixed in testing if tagged testing ++ # 5. Fixed in experimental if tagged experimental ++ # 6. at least 28 days have passed since the last action has occured or the bug was closed ++} ++ ++=head1 PRIVATE FUNCTIONS ++ ++=cut ++ ++sub update_realtime { ++ my ($file, $bug, $new) = @_; ++ ++ # update realtime index.db ++ ++ open(IDXDB, "<$file") or die "Couldn't open $file"; ++ open(IDXNEW, ">$file.new"); ++ ++ my $line; ++ my @line; ++ while($line = ) { ++ @line = split /\s/, $line; ++ last if ($line[1] >= $bug); ++ print IDXNEW $line; ++ $line = ""; ++ } ++ ++ if ($new eq "NOCHANGE") { - print IDXNEW $line if ($line ne "" && $line[1] == $ref); +++ print IDXNEW $line if ($line ne "" && $line[1] == $bug); ++ } elsif ($new eq "REMOVE") { ++ 0; ++ } else { ++ print IDXNEW $new; ++ } ++ if ($line ne "" && $line[1] > $bug) { ++ print IDXNEW $line; ++ $line = ""; ++ } ++ ++ print IDXNEW while(); ++ ++ close(IDXNEW); ++ close(IDXDB); ++ ++ rename("$file.new", $file); ++ ++ return $line; ++} ++ ++sub bughook_archive { ++ my $ref = shift; ++ &filelock("debbugs.trace.lock"); ++ &appendfile("debbugs.trace","archive $ref\n"); ++ my $line = update_realtime( - "$gSpoolDir/index.db.realtime", +++ "$config{spool_dir}/index.db.realtime", ++ $ref, ++ "REMOVE"); - update_realtime("$gSpoolDir/index.archive.realtime", +++ update_realtime("$config{spool_dir}/index.archive.realtime", ++ $ref, $line); ++ &unfilelock; ++} ++ ++sub bughook { ++ my ( $type, $ref, $data ) = @_; ++ &filelock("debbugs.trace.lock"); ++ ++ &appendfile("debbugs.trace","$type $ref\n",makestatus($data, 1)); ++ ++ my $whendone = "open"; - my $severity = $gDefaultSeverity; +++ my $severity = $config{default_severity}; ++ (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g; ++ $pkglist =~ s/^,+//; ++ $pkglist =~ s/,+$//; ++ $whendone = "forwarded" if length $data->{forwarded}; ++ $whendone = "done" if length $data->{done}; ++ $severity = $data->{severity} if length $data->{severity}; ++ ++ my $k = sprintf "%s %d %d %s [%s] %s %s\n", ++ $pkglist, $ref, $data->{date}, $whendone, ++ $data->{originator}, $severity, $data->{keywords}; ++ - update_realtime("$gSpoolDir/index.db.realtime", $ref, $k); +++ update_realtime("$config{spool_dir}/index.db.realtime", $ref, $k); ++ ++ &unfilelock; ++} ++ ++ ++ ++ ++1; ++ ++__END__ diff --cc Debbugs/User.pm index 4c831e1e,7591e4d1,d55860b2..7888f779 --- a/Debbugs/User.pm +++ b/Debbugs/User.pm @@@@ -44,6 -44,6 -44,6 +44,8 @@@@ use Fcntl ':flock' use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); use base qw(Exporter); +++use Debbugs::Config qw(:globals); +++ BEGIN { ($VERSION) = q$Revision: 1.4 $ =~ /^Revision:\s+([^\s+])/; $DEBUG = 0 unless defined $DEBUG; @@@@ -53,11 -53,8 -53,8 +55,6 @@@@ $EXPORT_TAGS{all} = [@EXPORT_OK]; } - my $gSpoolDir = "/org/bugs.debian.org/spool"; - if (defined($debbugs::gSpoolDir)) { - $gSpoolDir = $debbugs::gSpoolDir; - } --my $gSpoolPath = "/org/bugs.debian.org/spool"; --- # Obsolete compatability functions sub read_usertags { diff --cc bin/add_bug_to_estraier index 048708bc,00000000,00000000..f6d0cd51 mode 100755,000000,000000..100755 --- a/bin/add_bug_to_estraier +++ b/bin/add_bug_to_estraier @@@@ -1,231 -1,0 -1,0 +1,233 @@@@ ++#!/usr/bin/perl ++# add_bug_to_estraier adds a log for a bug to the estaier db, and is ++# released under the terms of the GPL version 2, or any later version, ++# at your option. See the file README and COPYING for more ++# information. ++# Copyright 2006 by Don Armstrong . ++ ++ ++ ++use warnings; ++use strict; ++ ++ ++use Getopt::Long; ++use Pod::Usage; ++ ++=head1 NAME ++ ++add_bug_to_estraier ++ ++=head1 SYNOPSIS ++ ++add_bug_to_estraier [options] < list_of_bugs_to_add ++ ++ Options: ++ --debug, -d debugging level (Default 0) ++ --help, -h display this help ++ --man, -m display manual ++ ++=head1 OPTIONS ++ ++=over ++ ++=item B<--url, -u> ++ ++Url to the estraier node ++ ++=item B<--user,-U> ++ ++User to log onto the estraier node ++ ++=item B<--pass,-P> ++ ++Password to log onto the estraier node ++ ++=item B<--spool,-s> ++ ++Spool location; if not set defaults to /etc/debbugs/config ++ ++=item B<--conf,-C> ++ ++Configuration file; a set of key = value pairs separated by newlines; ++the long name of any option is the name that the configuration file ++takes ++ ++=item B<--cron> ++ ++Descend through the spool and add all of the bugs to estraier ++ ++=item B<--timestamp> ++ ++Use the timestamp file to only add new bugs; will lock the timestamp ++file to avoid racing with other invocations ++ ++=item B<--debug, -d> ++ ++Debug verbosity. (Default 0) ++ ++=item B<--help, -h> ++ ++Display brief useage information. ++ ++=item B<--man, -m> ++ ++Display this manual. ++ ++=back ++ ++ ++=head1 EXAMPLES ++ ++ test_bts --bug 7 --host donbugs.donarmstrong.com ++ ++ ++=cut ++ ++ +++use Debbugs::Config qw(:globals); ++use Debbugs::Mail qw(send_mail_message); ++use Debbugs::MIME qw(create_mime_message); ++ ++use Search::Estraier; ++use Debbugs::Estraier qw(:add); ++use File::Find; ++use File::stat; ++ ++use vars qw($DEBUG $VERBOSE); ++ ++# XXX parse config file ++ ++my %options = (debug => 0, ++ help => 0, ++ man => 0, ++ url => undef, ++ user => undef, ++ passwd => undef, ++ spool => undef, ++ conf => undef, ++ cron => 0, ++ timestamp => undef, ++ ); ++ ++GetOptions(\%options,'url|u=s','user|U=s','passwd|P=s', ++ 'spool|s=s','conf|C=s','cron!','timestamp=s', ++ 'debug|d+','help|h|?','man|m'); ++ ++my $ERRORS = ''; ++ ++if (not defined $options{conf}) { ++ $ERRORS .= "--url must be set\n" if not defined $options{url}; ++ $ERRORS .= "--user must be set\n" if not defined $options{user}; ++ $ERRORS .= "--passwd must be set\n" if not defined $options{passwd}; ++} ++else { ++ # Read the conf file ++ my $conf_fh = new IO::File $options{conf},'r' ++ or die "Unable to open $options{conf} for reading"; ++ while (<$conf_fh>) { ++ chomp; ++ next if /^\s*\#/; ++ my ($key,$value) = split /\s*[:=]\s*/,$_,2; ++ $options{$key} = $value if defined $key and not defined $options{$key}; ++ } ++ $ERRORS .= "url must be set\n" if not defined $options{url}; ++ $ERRORS .= "user must be set\n" if not defined $options{user}; ++ $ERRORS .= "passwd must be set\n" if not defined $options{passwd}; ++} ++$ERRORS .= "--spool must be set if --cron is used\n" if ++ not defined $options{spool} and $options{cron}; ++pod2usage($ERRORS) if length $ERRORS; ++ ++pod2usage() if $options{help}; ++pod2usage({verbose=>2}) if $options{man}; ++ ++ ++$DEBUG = $options{debug}; ++ ++$Debbugs::Estraier::DEBUG = $DEBUG; ++$VERBOSE = 0; ++ ++my $node = new Search::Estraier::Node (url => $options{url}, ++ user => $options{user}, ++ passwd => $options{passwd}, ++ ); - $Debbugs::Config::gSpoolDir = $options{spool} if defined $options{spool}; +++$gSpoolDir = $options{spool} if defined $options{spool}; ++ ++if ($options{cron}) { ++ my %timestamps; ++ my $start_time = time; ++ my $unlink = 0; ++ my %seen_dirs; ++ check_pid($options{timestamp}); ++ # read timestamp file ++ if (defined $options{timestamp}) { ++ my $timestamp_fh = new IO::File $options{timestamp},'r' or ++ die "Unable to open timestamp $options{timestamp}: $!"; ++ while (<$timestamp_fh>) { ++ chomp; ++ my ($key,$value) = split /\s+/,$_,2; ++ $timestamps{$key} = $value; ++ } ++ } ++ for my $hash (map {sprintf '%02d',$_ } 0..99) { ++ find(sub { ++ print STDERR "Examining $_\n" if $DEBUG > 1; ++ return if not /^(\d+)\.log$/; ++ my $bug_num = $1; ++ my $stat = stat $_ or next; ++ return unless -f _; ++ return if exists $timestamps{$File::Find::dir} and ++ ($timestamps{$File::Find::dir} > $stat->mtime); ++ $seen_dirs{$File::Find::dir} = $start_time; ++ print STDERR "Adding $bug_num\n" if $DEBUG; +++ my $max_message = 0; ++ eval{ - add_bug_log($node,$bug_num); +++ $max_message = add_bug_log($node,$bug_num); ++ }; ++ if ($@) { ++ print STDERR "Adding $bug_num failed with $@\n"; ++ } ++ }, ++ map {(-d "$options{spool}/$_/$hash")? ++ "$options{spool}/$_/$hash":()} ++ qw(db-h archive), ++ ); ++ # write timestamp file ++ if (defined $options{timestamp}) { ++ %timestamps = (%timestamps,%seen_dirs); ++ my $timestamp_fh = new IO::File $options{timestamp},'w' or ++ die "Unable to open timestamp $options{timestamp}: $!"; ++ foreach my $key (keys %timestamps) { ++ print {$timestamp_fh} $key,' ', ++ $timestamps{$key}||'',qq(\n); ++ } ++ } ++ } ++ unlink("$options{timestamp}.pid"); ++} ++else { ++ while (my $bug_num = ) { ++ chomp $bug_num; ++ add_bug_log($node,$bug_num); ++ } ++} ++ ++ ++sub check_pid{ ++ my ($timestamp) = @_; ++ if (-e "${timestamp}.pid") { ++ my $time_fh = new IO::File "${timestamp}.pid", 'r' or die "Unable to read pidfile"; ++ local $/; ++ my $pid = <$time_fh>; ++ if (kill(0,$pid)) { ++ print STDERR "Another cron is running" and exit 0; ++ } ++ } ++ my $time_fh = new IO::File "${timestamp}.pid", 'w' or ++ die "Unable to read pidfile"; ++ print {$time_fh} $$; ++} ++ ++ ++__END__ diff --cc cgi/common.pl index 94e1eb35,e497787f,e497787f..a98a5708 --- a/cgi/common.pl +++ b/cgi/common.pl @@@@ -12,10 -12,9 -12,9 +12,13 @@@@ $config_path = '/etc/debbugs' $lib_path = '/usr/lib/debbugs'; require "$lib_path/errorlib"; ---use Debbugs::Packages; +++use Debbugs::Packages qw(:versions :mapping); use Debbugs::Versions; use Debbugs::MIME qw(decode_rfc1522); - use Debbugs::Common qw(:read :util); +++use Debbugs::Common qw(:util); +++use Debbugs::Status qw(:read :versions); +++use Debbugs::CGI qw(:all); +++ $MLDBM::RemoveTaint = 1; @@@@ -259,34 -258,34 -258,34 +262,11 @@@@ sub splitpackages return map lc, split /[ \t?,()]+/, $pkgs; } ---my %_parsedaddrs; ---sub getparsedaddrs { --- my $addr = shift; --- return () unless defined $addr; --- return @{$_parsedaddrs{$addr}} if exists $_parsedaddrs{$addr}; --- @{$_parsedaddrs{$addr}} = Mail::Address->parse($addr); --- return @{$_parsedaddrs{$addr}}; ---} --- # Generate a comma-separated list of HTML links to each package given in # $pkgs. $pkgs may be empty, in which case an empty string is returned, or # it may be a comma-separated list of package names. sub htmlpackagelinks { --- my $pkgs = shift; --- return unless defined $pkgs and $pkgs ne ''; --- my $strong = shift; --- my @pkglist = splitpackages($pkgs); --- --- my $openstrong = $strong ? '' : ''; --- my $closestrong = $strong ? '' : ''; --- --- return 'Package' . (@pkglist > 1 ? 's' : '') . ': ' . --- join(', ', --- map { --- '' . --- $openstrong . htmlsanit($_) . $closestrong . '' --- } @pkglist --- ); +++ return htmlize_packagelinks(@_); } # Generate a comma-separated list of HTML links to each address given in @@@@ -294,20 -293,20 -293,20 +274,7 @@@@ # $urlfunc should be a reference to a function like mainturl or submitterurl # which returns the URL for each individual address. sub htmladdresslinks { --- my ($prefixfunc, $urlfunc, $addresses) = @_; --- if (defined $addresses and $addresses ne '') { --- my @addrs = getparsedaddrs($addresses); --- my $prefix = (ref $prefixfunc) ? $prefixfunc->(scalar @addrs) --- : $prefixfunc; --- return $prefix . --- join ', ', map { sprintf '%s', --- $urlfunc->($_->address), --- htmlsanit($_->format) || '(unknown)' --- } @addrs; --- } else { --- my $prefix = (ref $prefixfunc) ? $prefixfunc->(1) : $prefixfunc; --- return sprintf '%s(unknown)', $prefix, $urlfunc->(''); --- } +++ htmlize_addresslinks(@_); } # Generate a comma-separated list of HTML links to each maintainer given in @@@@ -367,7 -366,7 -366,7 +334,6 @@@@ sub htmlindexentrystatus . htmlsanit(join(", ", sort(split(/\s+/, $status{tags})))) . "" if (length($status{tags})); --- my @merged= split(/ /,$status{mergedwith}); my $mseparator= ";\nmerged with "; for my $m (@merged) { @@@@ -430,11 -429,11 -429,11 +396,11 @@@@ sub urlargs return $args; } ---sub submitterurl { pkg_etc_url(emailfromrfc822($_[0] || ""), "submitter"); } ---sub mainturl { pkg_etc_url(emailfromrfc822($_[0] || ""), "maint"); } ---sub pkgurl { pkg_etc_url($_[0] || "", "pkg"); } ---sub srcurl { pkg_etc_url($_[0] || "", "src"); } ---sub tagurl { pkg_etc_url($_[0] || "", "tag"); } +++sub submitterurl { pkg_url(submitter => emailfromrfc822($_[0] || "")); } +++sub mainturl { pkg_url(maint => emailfromrfc822($_[0] || "")); } +++sub pkgurl { pkg_url(pkg => $_[0] || ""); } +++sub srcurl { pkg_url(src => $_[0] || ""); } +++sub tagurl { pkg_url(tag => $_[0] || ""); } sub pkg_etc_url { my $ref = shift; @@@@ -468,15 -467,15 -467,15 +434,6 @@@@ sub htmlsanit return $in; } ---sub maybelink { --- my $in = shift; --- if ($in =~ /^[a-zA-Z0-9+.-]+:/) { # RFC 1738 scheme --- return qq{} . htmlsanit($in) . ''; --- } else { --- return htmlsanit($in); --- } ---} --- sub bugurl { my $ref = shift; my $params = "bug=$ref"; @@@@ -957,37 -959,37 -959,37 +917,6 @@@@ sub buggyversion return $tree->buggy($ver, \@found, \@fixed); } ---my %_versions; ---sub getversions { --- my ($pkg, $dist, $arch) = @_; --- return () unless defined $debbugs::gVersionIndex; --- $dist = 'unstable' unless defined $dist; --- --- unless (tied %_versions) { --- tie %_versions, 'MLDBM', $debbugs::gVersionIndex, O_RDONLY --- or die "can't open versions index: $!"; --- } --- --- if (defined $arch and exists $_versions{$pkg}{$dist}{$arch}) { --- my $ver = $_versions{$pkg}{$dist}{$arch}; --- return $ver if defined $ver; --- return (); --- } else { --- my %uniq; --- for my $ar (keys %{$_versions{$pkg}{$dist}}) { --- $uniq{$_versions{$pkg}{$dist}{$ar}} = 1 unless $ar eq 'source'; --- } --- if (%uniq) { --- return keys %uniq; --- } elsif (exists $_versions{$pkg}{$dist}{source}) { --- # Maybe this is actually a source package with no corresponding --- # binaries? --- return $_versions{$pkg}{$dist}{source}; --- } else { --- return (); --- } --- } ---} sub getversiondesc { my $pkg = shift; diff --cc cgi/pkgreport.cgi index 154c845f,cce3fbd4,a6c8e8d3..6f9e10de --- a/cgi/pkgreport.cgi +++ b/cgi/pkgreport.cgi @@@@ -12,6 -12,6 -12,6 +12,7 @@@@ require '/etc/debbugs/config' require '/etc/debbugs/text'; use Debbugs::User; +++use Debbugs::CGI qw(version_url); use vars qw($gPackagePages $gWebDomain %gSeverityDisplay @gSeverityList); @@@@ -93,7 -93,7 -93,7 +94,7 @@@@ my %cats = "pri" => [map { "severity=$_" } @debbugs::gSeverityList], "ttl" => [map { $debbugs::gSeverityDisplay{$_} } @debbugs::gSeverityList], "def" => "Unknown Severity", --- "ord" => [0,1,2,3,4,5,6,7], +++ "ord" => [0..@debbugs::gSeverityList], } ], "classification" => [ { "nam" => "Classification", @@@@ -181,10 -181,10 -181,10 +182,7 @@@@ my $this = "" my %indexentry; my %strings = (); ---$ENV{"TZ"} = 'UTC'; ---tzset(); --- ---my $dtime = strftime "%a, %e %b %Y %T UTC", localtime; +++my $dtime = strftime "%a, %e %b %Y %T UTC", gmtime; my $tail_html = $debbugs::gHTMLTail; $tail_html = $debbugs::gHTMLTail; $tail_html =~ s/SUBSTITUTE_DTIME/$dtime/; @@@@ -608,7 -621,7 -621,7 +619,11 @@@@ sub pkg_htmlindexentrystatus s{/}{ } foreach @fixed; $showversions .= join ', ', map htmlsanit($_), @fixed; } --- $result .= " ($showversions)" if length $showversions; +++ $result .= ' ($showversions)} if length $showversions; $result .= ";\n"; $result .= $showseverity; @@@@ -642,7 -655,10 -656,10 +658,10 @@@@ unless (length($status{done})) { if (length($status{forwarded})) { $result .= ";\nForwarded to " - . maybelink($status{forwarded}); + . join(', ', + map {maybelink($_)} -- split /,\s*/,$status{forwarded} +++ split /[,\s]+/,$status{forwarded} + ); } my $daysold = int((time - $status{date}) / 86400); # seconds to days if ($daysold >= 7) { @@@@ -808,20 -824,20 -825,20 +827,7 @@@@ sub pkg_htmlpackagelinks } sub pkg_htmladdresslinks { --- my ($prefixfunc, $urlfunc, $addresses) = @_; --- if (defined $addresses and $addresses ne '') { --- my @addrs = getparsedaddrs($addresses); --- my $prefix = (ref $prefixfunc) ? $prefixfunc->(scalar @addrs) --- : $prefixfunc; --- return $prefix . --- join ', ', map { sprintf '%s', --- $urlfunc->($_->address), --- htmlsanit($_->format) || '(unknown)' --- } @addrs; --- } else { --- my $prefix = (ref $prefixfunc) ? $prefixfunc->(1) : $prefixfunc; --- return sprintf '%s(unknown)', $prefix, $urlfunc->(''); --- } +++ htmlize_addresslinks(@_,'submitter'); } sub pkg_javascript { @@@@ -830,6 -846,7 -847,7 +836,7 @@@@