@EXPORT = ();
%EXPORT_TAGS = (versions => [qw(getversions)],
mapping => [qw(getpkgsrc getpkgcomponent getsrcpkgs),
- qw(binarytosource sourcetobinary)
+ qw(binarytosource sourcetobinary makesourceversions)
],
);
@EXPORT_OK = ();
use Fcntl qw(O_RDONLY);
use MLDBM qw(DB_File Storable);
+use Storable qw(dclone);
+$MLDBM::DumpMeth = 'portable';
$MLDBM::RemoveTaint = 1;
=head1 NAME
my $_pkgsrc;
my $_pkgcomponent;
+my $_srcpkg;
sub getpkgsrc {
return $_pkgsrc if $_pkgsrc;
return {} unless defined $Debbugs::Packages::gPackageSource;
my %pkgsrc;
my %pkgcomponent;
+ my %srcpkg;
open(MM,"$Debbugs::Packages::gPackageSource")
or die("open $Debbugs::Packages::gPackageSource: $!");
my ($bin,$cmp,$src)=($1,$2,$3);
$bin =~ y/A-Z/a-z/;
$pkgsrc{$bin}= $src;
+ push @{$srcpkg{$src}}, $bin;
$pkgcomponent{$bin}= $cmp;
}
close(MM);
$_pkgsrc = \%pkgsrc;
$_pkgcomponent = \%pkgcomponent;
+ $_srcpkg = \%srcpkg;
return $_pkgsrc;
}
sub getsrcpkgs {
my $src = shift;
- return () if !$src;
- my %pkgsrc = %{getpkgsrc()};
- my @pkgs;
- foreach ( keys %pkgsrc ) {
- push @pkgs, $_ if $pkgsrc{$_} eq $src;
- }
- return @pkgs;
+ getpkgsrc() if not defined $_srcpkg;
+ return () if not defined $src or not exists $_srcpkg->{$src};
+ return @{$_srcpkg->{$src}};
}
=item binarytosource
tie %_binarytosource, 'MLDBM',
$Debbugs::Packages::gBinarySourceMap, O_RDONLY) {
# avoid autovivification
- if (exists $_binarytosource{$binname} and
- exists $_binarytosource{$binname}{$binver}) {
+ my $binary = $_binarytosource{$binname};
+ return () unless defined $binary;
+ my %binary = %{$binary};
+ if (exists $binary{$binver}) {
if (defined $binarch) {
- my $src = $_binarytosource{$binname}{$binver}{$binarch};
+ my $src = $binary{$binver}{$binarch};
return () unless defined $src; # not on this arch
# Copy the data to avoid tiedness problems.
- return [@$src];
+ 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 %{$_binarytosource{$binname}{$binver}}) {
- my $src = $_binarytosource{$binname}{$binver}{$ar};
+ for my $ar (keys %{$binary{$binver}}) {
+ my $src = $binary{$binver}{$ar};
next unless defined $src;
$uniq{$src->[0]}{$src->[1]} = 1;
}
tie %_sourcetobinary, 'MLDBM',
$Debbugs::Packages::gSourceBinaryMap, O_RDONLY) {
# avoid autovivification
- if (exists $_sourcetobinary{$srcname} and
- exists $_sourcetobinary{$srcname}{$srcver}) {
- my $bin = $_sourcetobinary{$srcname}{$srcver};
+ my $source = $_sourcetobinary{$srcname};
+ return () unless defined $source;
+ my %source = %{$source};
+ if (exists $source{$srcver}) {
+ my $bin = $source{$srcver};
return () unless defined $bin;
- # Copy the data to avoid tiedness problems.
return @$bin;
}
}
=item getversions
-Returns versions of the package in distribution at a specific architecture
+Returns versions of the package in a distribution at a specific
+architecture
=cut
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 $_versions{$pkg}{$dist}{$arch}) {
- my $ver = $_versions{$pkg}{$dist}{$arch};
+ if (defined $arch and exists $version{$dist}{$arch}) {
+ my $ver = $version{$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';
+ for my $ar (keys %{$version{$dist}}) {
+ $uniq{$version{$dist}{$ar}} = 1 unless $ar eq 'source';
}
if (%uniq) {
return keys %uniq;
- } elsif (exists $_versions{$pkg}{$dist}{source}) {
+ } elsif (exists $version{$dist}{source}) {
# Maybe this is actually a source package with no corresponding
# binaries?
- return $_versions{$pkg}{$dist}{source};
+ return $version{$dist}{source};
} else {
return ();
}
}
+=item makesourceversions
+
+ @{$cgi_var{found}} = makesourceversions($cgi_var{package},undef,@{$cgi_var{found}});
+
+Canonicalize versions into source versions, which have an explicitly
+named source package. This is used to cope with source packages whose
+names have changed during their history, and with cases where source
+version numbers differ from binary version numbers.
+
+=cut
+
+my %_sourceversioncache = ();
+sub makesourceversions {
+ my $pkg = shift;
+ my $arch = shift;
+ my %sourceversions;
+
+ for my $version (@_) {
+ if ($version =~ m[/]) {
+ # Already a source version.
+ $sourceversions{$version} = 1;
+ } else {
+ my $cachearch = (defined $arch) ? $arch : '';
+ my $cachekey = "$pkg/$cachearch/$version";
+ if (exists($_sourceversioncache{$cachekey})) {
+ for my $v (@{$_sourceversioncache{$cachekey}}) {
+ $sourceversions{$v} = 1;
+ }
+ next;
+ }
+
+ my @srcinfo = binarytosource($pkg, $version, $arch);
+ unless (@srcinfo) {
+ # We don't have explicit information about the
+ # binary-to-source mapping for this version (yet). Since
+ # this is a CGI script and our output is transient, we can
+ # get away with just looking in the unversioned map; if it's
+ # wrong (as it will be when binary and source package
+ # versions differ), too bad.
+ my $pkgsrc = getpkgsrc();
+ if (exists $pkgsrc->{$pkg}) {
+ @srcinfo = ([$pkgsrc->{$pkg}, $version]);
+ } elsif (getsrcpkgs($pkg)) {
+ # If we're looking at a source package that doesn't have
+ # a binary of the same name, just try the same version.
+ @srcinfo = ([$pkg, $version]);
+ } else {
+ next;
+ }
+ }
+ $sourceversions{"$_->[0]/$_->[1]"} = 1 foreach @srcinfo;
+ $_sourceversioncache{$cachekey} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
+ }
+ }
+
+ return sort keys %sourceversions;
+}
+
+
=back
use Debbugs::Common qw(:util);
use Debbugs::Status qw(:read :versions);
use Debbugs::CGI qw(:all);
-
+use Debbugs::Config qw(:globals);
$MLDBM::RemoveTaint = 1;
my @common_grouping = ( 'severity', 'pending' );
my %common_grouping_order = (
'pending' => [ qw( pending forwarded pending-fixed fixed done absent ) ],
- 'severity' => \@debbugs::gSeverityList,
+ 'severity' => \@gSeverityList,
);
my %common_grouping_display = (
'pending' => 'Status',
"forwarded" => "forwarded to upstream software authors",
"absent" => "not applicable to this version",
},
- 'severity' => \%debbugs::gSeverityDisplay,
+ 'severity' => \%gSeverityDisplay,
);
my $common_version;
$use_bug_idx = $val;
if ( $val ) {
$common_headers{pending}{open} = $common_headers{pending}{pending};
- my $bugidx = tie %bugidx, MLDBM => "$debbugs::gSpoolDir/realtime/bug.idx", O_RDONLY
- or quitcgi( "$0: can't open $debbugs::gSpoolDir/realtime/bug.idx ($!)\n" );
+ my $bugidx = tie %bugidx, MLDBM => "$gSpoolDir/realtime/bug.idx", O_RDONLY
+ or quitcgi( "$0: can't open $gSpoolDir/realtime/bug.idx ($!)\n" );
$bugidx->RemoveTaint(1);
} else {
untie %bugidx;
if (length($status{done})) {
$result .= ";\n<strong>Done:</strong> " . htmlsanit($status{done});
- $days = ceil($debbugs::gRemoveAge - -M buglog($status{id}));
+ $days = ceil($gRemoveAge - -M buglog($status{id}));
if ($days >= 0) {
$result .= ";\n<strong>Will be archived:</strong>" . ( $days == 0 ? " today" : $days == 1 ? " in $days day" : " in $days days" );
} else {
}
$result = $header . $result if ( $common{show_list_header} );
- $result .= $debbugs::gHTMLExpireNote if $debbugs::gRemoveAge and $anydone;
+ $result .= $gHTMLExpireNote if $gRemoveAge and $anydone;
$result .= "<hr>" . $footer if ( $common{show_list_footer} );
return $result;
}
sub countbugs {
my $bugfunc = shift;
if ($common_archive) {
- open I, "<$debbugs::gSpoolDir/index.archive"
- or &quitcgi("$debbugs::gSpoolDir/index.archive: $!");
+ open I, "<$gSpoolDir/index.archive"
+ or &quitcgi("$gSpoolDir/index.archive: $!");
} else {
- open I, "<$debbugs::gSpoolDir/index.db"
- or &quitcgi("$debbugs::gSpoolDir/index.db: $!");
+ open I, "<$gSpoolDir/index.db"
+ or &quitcgi("$gSpoolDir/index.db: $!");
}
my %count = ();
if (!defined $opt) {
# leave $fastidx undefined;
} elsif (!$common_archive) {
- $fastidx = "$debbugs::gSpoolDir/by-$opt.idx";
+ $fastidx = "$gSpoolDir/by-$opt.idx";
} else {
- $fastidx = "$debbugs::gSpoolDir/by-$opt-arc.idx";
+ $fastidx = "$gSpoolDir/by-$opt-arc.idx";
}
if (defined $fastidx && -e $fastidx) {
print STDERR "done optimized\n" if ($debug);
} else {
if ( $common_archive ) {
- open I, "<$debbugs::gSpoolDir/index.archive"
- or &quitcgi("$debbugs::gSpoolDir/index.archive: $!");
+ open I, "<$gSpoolDir/index.archive"
+ or &quitcgi("$gSpoolDir/index.archive: $!");
} else {
- open I, "<$debbugs::gSpoolDir/index.db"
- or &quitcgi("$debbugs::gSpoolDir/index.db: $!");
+ open I, "<$gSpoolDir/index.db"
+ or &quitcgi("$gSpoolDir/index.db: $!");
}
while(<I>) {
if (m/^(\S+)\s+(\d+)\s+(\d+)\s+(\S+)\s+\[\s*([^]]*)\s*\]\s+(\w+)\s+(.*)$/) {
return $_maintainer if $_maintainer;
my %maintainer;
- open(MM,"$debbugs::gMaintainerFile") or &quitcgi("open $debbugs::gMaintainerFile: $!");
+ open(MM,"$gMaintainerFile") or &quitcgi("open $gMaintainerFile: $!");
while(<MM>) {
next unless m/^(\S+)\s+(\S.*\S)\s*$/;
($a,$b)=($1,$2);
$maintainer{$a}= $b;
}
close(MM);
- if (defined $debbugs::gMaintainerFileOverride) {
- open(MM,"$debbugs::gMaintainerFileOverride") or &quitcgi("open $debbugs::gMaintainerFileOverride: $!");
+ if (defined $gMaintainerFileOverride) {
+ open(MM,"$gMaintainerFileOverride") or &quitcgi("open $gMaintainerFileOverride: $!");
while(<MM>) {
next unless m/^(\S+)\s+(\S.*\S)\s*$/;
($a,$b)=($1,$2);
return $_pseudodesc if $_pseudodesc;
my %pseudodesc;
- open(PSEUDO, "< $debbugs::gPseudoDescFile") or &quitcgi("open $debbugs::gPseudoDescFile: $!");
+ open(PSEUDO, "< $gPseudoDescFile") or &quitcgi("open $gPseudoDescFile: $!");
while(<PSEUDO>) {
next unless m/^(\S+)\s+(\S.*\S)\s*$/;
$pseudodesc{lc $1} = $2;
return getbugcomponent($bugnum, 'log.gz', $location);
}
-# Canonicalize versions into source versions, which have an explicitly
-# named source package. This is used to cope with source packages whose
-# names have changed during their history, and with cases where source
-# version numbers differ from binary version numbers.
-my %_sourceversioncache = ();
-sub makesourceversions {
- my $pkg = shift;
- my $arch = shift;
- my %sourceversions;
-
- for my $version (@_) {
- if ($version =~ m[/]) {
- # Already a source version.
- $sourceversions{$version} = 1;
- } else {
- my $cachearch = (defined $arch) ? $arch : '';
- my $cachekey = "$pkg/$cachearch/$version";
- if (exists($_sourceversioncache{$cachekey})) {
- for my $v (@{$_sourceversioncache{$cachekey}}) {
- $sourceversions{$v} = 1;
- }
- next;
- }
-
- my @srcinfo = binarytosource($pkg, $version, $arch);
- unless (@srcinfo) {
- # We don't have explicit information about the
- # binary-to-source mapping for this version (yet). Since
- # this is a CGI script and our output is transient, we can
- # get away with just looking in the unversioned map; if it's
- # wrong (as it will be when binary and source package
- # versions differ), too bad.
- my $pkgsrc = getpkgsrc();
- if (exists $pkgsrc->{$pkg}) {
- @srcinfo = ([$pkgsrc->{$pkg}, $version]);
- } elsif (getsrcpkgs($pkg)) {
- # If we're looking at a source package that doesn't have
- # a binary of the same name, just try the same version.
- @srcinfo = ([$pkg, $version]);
- } else {
- next;
- }
- }
- $sourceversions{"$_->[0]/$_->[1]"} = 1 foreach @srcinfo;
- $_sourceversioncache{$cachekey} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
- }
- }
-
- return sort keys %sourceversions;
-}
my %_versionobj;
sub buggyversion {
my ($bug, $ver, $status) = @_;
- return '' unless defined $debbugs::gVersionPackagesDir;
+ return '' unless defined $gVersionPackagesDir;
my $src = getpkgsrc()->{$status->{package}};
$src = $status->{package} unless defined $src;
} else {
$tree = Debbugs::Versions->new(\&DpkgVer::vercmp);
my $srchash = substr $src, 0, 1;
- if (open VERFILE, "< $debbugs::gVersionPackagesDir/$srchash/$src") {
+ if (open VERFILE, "< $gVersionPackagesDir/$srchash/$src") {
$tree->load(\*VERFILE);
close VERFILE;
}
projects / debbugs.git / commitdiff