+# This module is part of debbugs, 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 2007 by Don Armstrong <don@donarmstrong.com>.
package Debbugs::Bugs;
+# This module is part of debbugs, 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.
+#
+# [Other people have contributed to this file; their copyrights should
+# go here too.]
+# Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
package Debbugs::CGI;
+# This module is part of debbugs, 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.
+#
+# [Other people have contributed to this file; their copyrights should
+# go here too.]
+# Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
package Debbugs::Common;
+# This module is part of debbugs, 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 2007 by Don Armstrong <don@donarmstrong.com>.
package Debbugs::Config;
qw($gIncomingDir $gWebDir $gDocDir $gMaintainerFile),
qw($gMaintainerFileOverride $gPseudoDescFile $gPackageSource),
qw($gVersionPackagesDir $gVersionIndex $gBinarySourceMap $gSourceBinaryMap),
+ qw($gVersionTimeIndex),
qw($gSendmail $gLibPath $gSpamScan @gExcludeFromControl),
qw(%gSeverityDisplay @gTags @gSeverityList @gStrongSeverities),
qw(%gSearchEstraier),
set_default(\%config,'pseudo_desc_file',$config{config_dir}.'/pseudo-packages.description');
set_default(\%config,'package_source',$config{config_dir}.'/indices/sources');
+
+=item version_packages_dir
+
+Location where the version package information is kept; defaults to
+spool_dir/../versions/pkg
+
+=cut
+
set_default(\%config,'version_packages_dir',$config{spool_dir}.'/../versions/pkg');
+=item version_time_index
+
+Location of the version/time index file. Defaults to
+spool_dir/../versions/idx/versions_time.idx if spool_dir/../versions
+exists; otherwise defaults to undef.
+
+=cut
+
+
+set_default(\%config,'version_time_index', -d $config{spool_dir}.'/../versions' ? $config{spool_dir}.'/../versions/indices/versions_time.idx' : undef);
+
+=item version_index
+
+Location of the version index file. Defaults to
+spool_dir/../versions/indices/versions.idx if spool_dir/../versions
+exists; otherwise defaults to undef.
+
+=cut
+
+set_default(\%config,'version_index',-d $config{spool_dir}.'/../versions' ? $config{spool_dir}.'/../versions/indices/versions.idx' : undef);
+
+=item binary_source_map
+
+Location of the binary -> source map. Defaults to
+spool_dir/../versions/indices/bin2src.idx if spool_dir/../versions
+exists; otherwise defaults to undef.
+
+=cut
+
+set_default(\%config,'binary_source_map',-d $config{spool_dir}.'/../versions' ? $config{spool_dir}.'/../versions/indices/binsrc.idx' : undef);
+
+=item source_binary_map
+
+Location of the source -> binary map. Defaults to
+spool_dir/../versions/indices/src2bin.idx if spool_dir/../versions
+exists; otherwise defaults to undef.
+
+=cut
+
+set_default(\%config,'source_binary_map',-d $config{spool_dir}.'/../versions' ? $config{spool_dir}.'/../versions/indices/srcbin.idx' : undef);
+
+
+
set_default(\%config,'post_processall',[]);
=item sendmail
-package Debbugs::Email;
+package Debbugs::Email;
use strict;
+# This module is part of debbugs, 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 2007 by Don Armstrong <don@donarmstrong.com>.
package Debbugs::Estraier;
+# This module is part of debbugs, 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.
+#
+# [Other people have contributed to this file; their copyrights should
+# go here too.]
+# Copyright 2004 by Collin Waston <cjwatson@debian.org>
+
+
package Debbugs::Log;
use strict;
+# This module is part of debbugs, 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.
+#
+# [Other people have contributed to this file; their copyrights should
+# go here too.]
+# Copyright 2006 by Don Armstrong <don@donarmstrong.com>.
+
+
package Debbugs::MIME;
use strict;
-# $Id: Mail.pm,v 1.1 2005/08/17 21:46:16 don Exp $
+# This module is part of debbugs, 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 2004-7 by Don Armstrong <don@donarmstrong.com>.
package Debbugs::Mail;
+# This module is part of debbugs, 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.
+#
+# [Other people have contributed to this file; their copyrights should
+# go here too.]
+# Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
+
package Debbugs::Packages;
use warnings;
$VERSION = 1.00;
@EXPORT = ();
- %EXPORT_TAGS = (versions => [qw(getversions)],
+ %EXPORT_TAGS = (versions => [qw(getversions get_versions)],
mapping => [qw(getpkgsrc getpkgcomponent getsrcpkgs),
qw(binarytosource sourcetobinary makesourceversions)
],
use Fcntl qw(O_RDONLY);
use MLDBM qw(DB_File Storable);
use Storable qw(dclone);
+use Params::Validate qw(validate_with :types);
+use Debbugs::Common qw(make_list);
+
+use List::Util qw(min max);
$MLDBM::DumpMeth = 'portable';
$MLDBM::RemoveTaint = 1;
# need an extra cache for speed here.
return () unless defined $gBinarySourceMap;
- if (tied %_binarytosource or
- tie %_binarytosource, 'MLDBM',
- $gBinarySourceMap, O_RDONLY) {
- # avoid autovivification
- my $binary = $_binarytosource{$binname};
- return () unless defined $binary;
- my %binary = %{$binary};
- if (exists $binary{$binver}) {
- if (defined $binarch) {
- my $src = $binary{$binver}{$binarch};
- return () unless defined $src; # not on this arch
- # Copy the data to avoid tiedness problems.
- return dclone($src);
- } else {
- # Get (srcname, srcver) pairs for all architectures and
- # remove any duplicates. This involves some slightly tricky
- # multidimensional hashing; sorry. Fortunately there'll
- # usually only be one pair returned.
- my %uniq;
- for my $ar (keys %{$binary{$binver}}) {
- my $src = $binary{$binver}{$ar};
- next unless defined $src;
- $uniq{$src->[0]}{$src->[1]} = 1;
- }
- my @uniq;
- for my $sn (sort keys %uniq) {
- push @uniq, [$sn, $_] for sort keys %{$uniq{$sn}};
- }
- return @uniq;
- }
- }
+ if (not tied %_binarytosource) {
+ tie %_binarytosource, MLDBM => $gBinarySourceMap, O_RDONLY or
+ die "Unable to open $gBinarySourceMap for reading";
+ }
+
+ # avoid autovivification
+ my $binary = $_binarytosource{$binname};
+ return () unless defined $binary;
+ my %binary = %{$binary};
+ if (exists $binary{$binver}) {
+ if (defined $binarch) {
+ my $src = $binary{$binver}{$binarch};
+ return () unless defined $src; # not on this arch
+ # Copy the data to avoid tiedness problems.
+ return dclone($src);
+ } else {
+ # Get (srcname, srcver) pairs for all architectures and
+ # remove any duplicates. This involves some slightly tricky
+ # multidimensional hashing; sorry. Fortunately there'll
+ # usually only be one pair returned.
+ my %uniq;
+ for my $ar (keys %{$binary{$binver}}) {
+ my $src = $binary{$binver}{$ar};
+ next unless defined $src;
+ $uniq{$src->[0]}{$src->[1]} = 1;
+ }
+ my @uniq;
+ for my $sn (sort keys %uniq) {
+ push @uniq, [$sn, $_] for sort keys %{$uniq{$sn}};
+ }
+ return @uniq;
+ }
}
# No $gBinarySourceMap, or it didn't have an entry for this name and
sub sourcetobinary {
my ($srcname, $srcver) = @_;
- if (tied %_sourcetobinary or
- tie %_sourcetobinary, 'MLDBM',
- $gSourceBinaryMap, O_RDONLY) {
- # avoid autovivification
- my $source = $_sourcetobinary{$srcname};
- return () unless defined $source;
- my %source = %{$source};
- if (exists $source{$srcver}) {
- my $bin = $source{$srcver};
- return () unless defined $bin;
- return @$bin;
- }
+ if (not tied %_sourcetobinary) {
+ tie %_sourcetobinary, MLDBM => $gSourceBinaryMap, O_RDONLY or
+ die "Unable top open $gSourceBinaryMap for reading";
}
+
+
+ # avoid autovivification
+ my $source = $_sourcetobinary{$srcname};
+ return () unless defined $source;
+ my %source = %{$source};
+ if (exists $source{$srcver}) {
+ my $bin = $source{$srcver};
+ return () unless defined $bin;
+ return @$bin;
+ }
# No $gSourceBinaryMap, or it didn't have an entry for this name and
# version. Try $gPackageSource (unversioned) instead.
my @srcpkgs = getsrcpkgs($srcname);
=cut
-our %_versions;
sub getversions {
my ($pkg, $dist, $arch) = @_;
- return () unless defined $gVersionIndex;
- $dist = 'unstable' unless defined $dist;
+ return get_versions(package=>$pkg,
+ dist => $dist,
+ defined $arch ? (arch => $arch):(),
+ );
+}
- unless (tied %_versions) {
- tie %_versions, 'MLDBM', $gVersionIndex, O_RDONLY
- or die "can't open versions index: $!";
- }
- my $version = $_versions{$pkg};
- return () unless defined $version;
- my %version = %{$version};
-
- if (defined $arch and exists $version{$dist}{$arch}) {
- my $ver = $version{$dist}{$arch};
- return $ver if defined $ver;
- return ();
- } else {
- my %uniq;
- for my $ar (keys %{$version{$dist}}) {
- $uniq{$version{$dist}{$ar}} = 1 unless $ar eq 'source';
- }
- if (%uniq) {
- return keys %uniq;
- } elsif (exists $version{$dist}{source}) {
- # Maybe this is actually a source package with no corresponding
- # binaries?
- return $version{$dist}{source};
- } else {
- return ();
- }
- }
+
+
+=head2 get_versions
+
+ get_version(package=>'foopkg',
+ dist => 'unstable',
+ arch => 'i386',
+ );
+
+Returns a list of the versions of package in the distributions and
+architectures listed. This routine only returns unique values.
+
+=over
+
+=item package -- package to return list of versions
+
+=item dist -- distribution (unstable, stable, testing); can be an
+arrayref
+
+=item arch -- architecture (i386, source, ...); can be an arrayref
+
+=item time -- returns a version=>time hash at which the newest package
+matching this version was uploaded
+
+=item source -- returns source/version instead of just versions
+
+=back
+
+=cut
+
+our %_versions;
+our %_versions_time;
+
+sub get_versions{
+ my %param = validate_with(params => \@_,
+ spec => {package => {type => SCALAR,
+ },
+ dist => {type => SCALAR|ARRAYREF,
+ default => 'unstable',
+ },
+ arch => {type => SCALAR|ARRAYREF,
+ optional => 1,
+ },
+ time => {type => BOOLEAN,
+ default => 0,
+ },
+ source => {type => BOOLEAN,
+ default => 0,
+ },
+ },
+ );
+ my $versions;
+ if ($param{time}) {
+ return () if not defined $gVersionTimeIndex;
+ unless (tied %_versions_time) {
+ tie %_versions_time, 'MLDBM', $gVersionTimeIndex, O_RDONLY
+ or die "can't open versions index $gVersionTimeIndex: $!";
+ }
+ $versions = \%_versions_time;
+ }
+ else {
+ return () if not defined $gVersionIndex;
+ unless (tied %_versions) {
+ tie %_versions, 'MLDBM', $gVersionIndex, O_RDONLY
+ or die "can't open versions index $gVersionIndex: $!";
+ }
+ $versions = \%_versions;
+ }
+ my %versions;
+ for my $package (make_list($param{package})) {
+ my $version = $versions->{$package};
+ next unless defined $version;
+ for my $dist (make_list($param{dist})) {
+ for my $arch (exists $param{arch}?
+ make_list($param{arch}):
+ (keys %{$version->{$dist}})) {
+ next unless defined $version->{$dist}{$arch};
+ for my $ver (ref $version->{$dist}{$arch} ?
+ keys %{$version->{$dist}{$arch}} :
+ $version->{$dist}{$arch}
+ ) {
+ my $f_ver = $ver;
+ if ($param{source}) {
+ ($f_ver) = makesourceversions($package,$arch,$ver);
+ }
+ if ($param{time}) {
+ $versions{$f_ver} = max($versions{$f_ver}||0,$version->{$dist}{$arch}{$ver});
+ }
+ else {
+ $versions{$f_ver} = 1;
+ }
+ }
+ }
+ }
+ }
+ if ($param{time}) {
+ return %versions
+ }
+ return keys %versions;
}
+# This module is part of debbugs, 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.
+#
+# [Other people have contributed to this file; their copyrights should
+# go here too.]
+# Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
package Debbugs::Status;
use Debbugs::Common qw(:util :lock :quit :misc);
use Debbugs::Config qw(:config);
use Debbugs::MIME qw(decode_rfc1522 encode_rfc1522);
-use Debbugs::Packages qw(makesourceversions getversions binarytosource);
+use Debbugs::Packages qw(makesourceversions getversions get_versions binarytosource);
use Debbugs::Versions;
use Debbugs::Versions::Dpkg;
use POSIX qw(ceil);
+use List::Util qw(min max);
+
BEGIN{
$VERSION = 1.00;
# There must be fixed_versions for us to look at the versioning
# information
+ my $min_fixed_time = time;
+ my $min_archive_days = 0;
if (@{$status->{fixed_versions}}) {
my %dist_tags;
@dist_tags{@{$config{removal_distribution_tags}}} =
(1) x @{$config{removal_distribution_tags}};
my %dists;
- @dists{@{$config{removal_default_distribution_tags}}} =
+ @dists{@{$config{removal_default_distribution_tags}}} =
(1) x @{$config{removal_default_distribution_tags}};
- for my $tag (split ' ', $status->{tags}) {
+ for my $tag (split ' ', ($status->{tags}||'')) {
next unless $dist_tags{$tag};
$dists{$tag} = 1;
}
my %source_versions;
- for my $dist (keys %dists){
- my @versions;
- @versions = getversions($status->{package},
- $dist,
- undef);
- # 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},
- $dist,
- @versions);
- @source_versions{@sourceversions} = (1) x @sourceversions;
- }
+ my @sourceversions = get_versions(package => $status->{package},
+ dist => [keys %dists],
+ source => 1,
+ );
+ @source_versions{@sourceversions} = (1) x @sourceversions;
+ # If the bug has not been fixed in the versions actually
+ # distributed, then it cannot be archived.
if ('found' eq max_buggy(bug => $param{bug},
sourceversions => [keys %source_versions],
found => $status->{found_versions},
)) {
return $cannot_archive;
}
+ # Since the bug has at least been fixed in the architectures
+ # that matters, we check to see how long it has been fixed.
+
+ # To do this, we order the times from most recent to oldest;
+ # when we come to the first found version, we stop.
+ # If we run out of versions, we only report the time of the
+ # last one.
+ my %time_versions = get_versions(package => $status->{package},
+ dist => [keys %dists],
+ source => 1,
+ time => 1,
+ );
+ for my $version (sort {$time_versions{$b} <=> $time_versions{$a}} keys %time_versions) {
+ my $buggy = buggy(bug => $param{bug},
+ version => $version,
+ found => $status->{found_versions},
+ fixed => $status->{fixed_versions},
+ version_cache => $version_cache,
+ package => $status->{package},
+ );
+ last if $buggy eq 'found';
+ $min_fixed_time = min($time_versions{$version},$min_fixed_time);
+ }
+ $min_archive_days = max($min_archive_days,ceil((time - $min_fixed_time)/(60*60*24)));
}
# 6. at least 28 days have passed since the last action has occured or the bug was closed
- # XXX We still need some more work here before we actually can archive;
- # we really need to track when a bug was closed in a version.
my $age = ceil($config{remove_age} - -M getbugcomponent($param{bug},'log'));
- if ($age > 0 ) {
- return $param{days_until}?$age:0;
+ if ($age > 0 or $min_archive_days > 0) {
+ return $param{days_until}?max($age,$min_archive_days):0;
}
else {
return $param{days_until}?0:1;
+# This module is part of debbugs, 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 2007 by Don Armstrong <don@donarmstrong.com>.
+# query_form is
+# Copyright 1995-2003 Gisle Aas.
+# Copyright 1995 Martijn Koster.
+
+
package Debbugs::URI;
=head1 NAME
+# This module is part of debbugs, 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.
+#
+# [Other people have contributed to this file; their copyrights should
+# go here too.]
+# Copyright 2004 by Anthony Towns
+
+
package Debbugs::User;
+# This module is part of debbugs, 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.
+#
+# [Other people have contributed to this file; their copyrights should
+# go here too.]
+
package Debbugs::Versions;
use strict;
+# This module is part of debbugs, 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 Colin Watson <cjwatson@debian.org>
+# Copyright Ian Jackson <iwj@debian.org>
+# Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
+
+
package Debbugs::Versions::Dpkg;
use strict;
my $body = $entity->bodyhandle->as_string;
$body = convert_to_utf8($body,$charset) if defined $charset;
$body = html_escape($body);
+ # Attempt to deal with format=flowed
+ if ($content_type =~ m/format\s*=\s*\"?flowed\"?/i) {
+ $body =~ s{^\s}{}mgo;
+ # we ignore the other things that you can do with
+ # flowed e-mails cause they don't really matter.
+ }
# Add links to URLs
$body =~ s,((ftp|http|https)://[\S~-]+?/?)((\>\;)?[)]?[']?[:.\,]?(\s|$)),<a href=\"$1\">$1</a>$3,go;
# Add links to bug closures
my %bugusertags;
my %ut;
for my $user (split /[\s*,]+/, $users) {
- next unless ($user =~ m/..../);
+ next unless length($user) >= 4;
add_user($user);
}
set_option("show_list_header", $show_list_header);
set_option("show_list_footer", $show_list_footer);
+our %seen_users;
sub add_user {
my $ut = \%ut;
my $u = shift;
+ return if $seen_users{$u};
+ $seen_users{$u} = 1;
+
my $user = Debbugs::User::get_user($u);
my %vis = map { $_, 1 } @{$user->{"visible_cats"}};
- lc submitter address for comparsion in pkgreport.cgi
(closes: #415628)
- Add quotes around retitle'd titles (closes: #419202)
+ - Don't automatically make categories hidden (closes: #415932)
+ - Don't duplicate ordering (closes: #415931)
- Make file locking portable (closes: #293277)
- Allow the package pages to be optional (closes: #234362)
- Fix package link code and link both packages (closes: #419553)
- Make the version regex correct (closes: #425614)
- Indicate the selected user (closes: #422934)
- Use source package for usertags where possible (closes: #415933)
+ - Add PR-Package header for control messages (closes: #414023)
+ - Fix double leading spaces of format=flowed messages
+ (closes: #428056)
+ - Don't doubly select users
+ - Implement versioning aware archiving support (closes: #419693)
-- Colin Watson <cjwatson@debian.org> Fri, 20 Jun 2003 18:57:25 +0100
$maintccs .= "Cc: " . join(",\n ",@maintccs) . "\n";
}
+my %packagepr;
+for my $maint (keys %maintccreasons) {
+ for my $package (keys %{$maintccreasons{$maint}}) {
+ next unless length $package;
+ $packagepr{$package} = 1;
+ }
+}
+my $packagepr = '';
+$packagepr = "X-${gProject}-PR-Package: " . join(keys %packagepr) . "\n" if keys %packagepr;
+
# Add Bcc's to subscribed bugs
push @bcc, map {"bugs=$_\@$gListDomain"} keys %bug_affected;
References: $header{'message-id'}
Message-ID: <handler.s.$nn.transcript\@$gEmailDomain>
Precedence: bulk
-X-$gProject-PR-Message: transcript
+${packagepr}X-$gProject-PR-Message: transcript
${transcript}Please contact me if you need assistance.
projects / debbugs.git / commitdiff