--- /dev/null
+package Debbugs::Packages;
+
+use strict;
+
+# TODO: move config handling to a separate module
+my $config_path = '/etc/debbugs';
+require "$config_path/config";
+
+use Exporter ();
+use vars qw($VERSION @ISA @EXPORT);
+
+BEGIN {
+ $VERSION = 1.00;
+
+ @ISA = qw(Exporter);
+ @EXPORT = qw(getpkgsrc getpkgcomponent getsrcpkgs
+ binarytosource sourcetobinary);
+}
+
+use Fcntl qw(O_RDONLY);
+use MLDBM qw(DB_File);
+
+$MLDBM::RemoveTaint = 1;
+
+=head1 NAME
+
+Debbugs::Packages - debbugs binary/source package handling
+
+=head1 DESCRIPTION
+
+The Debbugs::Packages module provides support functions to map binary
+packages to their corresponding source packages and vice versa. (This makes
+sense for software distributions, where developers may work on a single
+source package which produces several binary packages for use by users; it
+may not make sense in other contexts.)
+
+=head1 METHODS
+
+=over 8
+
+=item getpkgsrc
+
+Returns a reference to a hash of binary package names to their corresponding
+source package names.
+
+=cut
+
+my $_pkgsrc;
+my $_pkgcomponent;
+sub getpkgsrc {
+ return $_pkgsrc if $_pkgsrc;
+ return {} unless defined $Debbugs::Packages::gPackageSource;
+ my %pkgsrc;
+ my %pkgcomponent;
+
+ open(MM,"$Debbugs::Packages::gPackageSource")
+ or &quitcgi("open $Debbugs::Packages::gPackageSource: $!");
+ while(<MM>) {
+ next unless m/^(\S+)\s+(\S+)\s+(\S.*\S)\s*$/;
+ my ($bin,$cmp,$src)=($1,$2,$3);
+ $bin =~ y/A-Z/a-z/;
+ $pkgsrc{$bin}= $src;
+ $pkgcomponent{$bin}= $cmp;
+ }
+ close(MM);
+ $_pkgsrc = \%pkgsrc;
+ $_pkgcomponent = \%pkgcomponent;
+ return $_pkgsrc;
+}
+
+=item getpkgcomponent
+
+Returns a reference to a hash of binary package names to the component of
+the archive containing those binary packages (e.g. "main", "contrib",
+"non-free").
+
+=cut
+
+sub getpkgcomponent {
+ return $_pkgcomponent if $_pkgcomponent;
+ getpkgsrc();
+ return $_pkgcomponent;
+}
+
+=item getsrcpkgs
+
+Returns a list of the binary packages produced by a given source package.
+
+=cut
+
+sub getsrcpkgs {
+ my $src = shift;
+ return () if !$src;
+ my %pkgsrc = %{getpkgsrc()};
+ my @pkgs;
+ foreach ( keys %pkgsrc ) {
+ push @pkgs, $_ if $pkgsrc{$_} eq $src;
+ }
+ return @pkgs;
+}
+
+=item binarytosource
+
+Returns a reference to the source package name and version pair
+corresponding to a given binary package name, version, and architecture. If
+undef is passed as the architecture, returns a list of references to all
+possible pairs of source package names and versions for all architectures,
+with any duplicates removed.
+
+=cut
+
+my %_binarytosource;
+sub binarytosource {
+ my ($binname, $binver, $binarch) = @_;
+
+ # TODO: This gets hit a lot, especially from buggyversion() - probably
+ # need an extra cache for speed here.
+
+ if (tied %_binarytosource or
+ tie %_binarytosource, 'MLDBM',
+ $Debbugs::Packages::gBinarySourceMap, O_RDONLY) {
+ # avoid autovivification
+ if (exists $_binarytosource{$binname} and
+ exists $_binarytosource{$binname}{$binver}) {
+ if (defined $binarch) {
+ my $src = $_binarytosource{$binname}{$binver}{$binarch};
+ return () unless defined $src; # not on this arch
+ # Copy the data to avoid tiedness problems.
+ return [@$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};
+ 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
+ # version. Try $gPackageSource (unversioned) instead.
+ my $pkgsrc = getpkgsrc();
+ if (exists $pkgsrc->{$binname}) {
+ return [$pkgsrc->{$binname}, $binver];
+ } else {
+ return ();
+ }
+}
+
+=item sourcetobinary
+
+Returns a list of references to triplets of binary package names, versions,
+and architectures corresponding to a given source package name and version.
+If the given source package name and version cannot be found in the database
+but the source package name is in the unversioned package-to-source map
+file, then a reference to a binary package name and version pair will be
+returned, without the architecture.
+
+=cut
+
+my %_sourcetobinary;
+sub sourcetobinary {
+ my ($srcname, $srcver) = @_;
+
+ if (tied %_sourcetobinary or
+ tie %_sourcetobinary, 'MLDBM',
+ $Debbugs::Packages::gSourceBinaryMap, O_RDONLY) {
+ # avoid autovivification
+ if (exists $_sourcetobinary{$srcname} and
+ exists $_sourcetobinary{$srcname}{$srcver}) {
+ my $bin = $_sourcetobinary{$srcname}{$srcver};
+ return () unless defined $bin;
+ # Copy the data to avoid tiedness problems.
+ return @$bin;
+ }
+ }
+
+ # No $gSourceBinaryMap, or it didn't have an entry for this name and
+ # version. Try $gPackageSource (unversioned) instead.
+ my @srcpkgs = getsrcpkgs($srcname);
+ return map [$_, $srcver], @srcpkgs;
+}
+
+=back
+
+=cut
+
+1;
$lib_path = '/usr/lib/debbugs';
require "$lib_path/errorlib";
+use Debbugs::Packages;
use Debbugs::Versions;
use Debbugs::MIME qw(decode_rfc1522);
return $_maintainer;
}
-my $_pkgsrc;
-my $_pkgcomponent;
-sub getpkgsrc {
- return $_pkgsrc if $_pkgsrc;
- return {} unless defined $gPackageSource;
- my %pkgsrc;
- my %pkgcomponent;
-
- open(MM,"$gPackageSource") or &quitcgi("open $gPackageSource: $!");
- while(<MM>) {
- next unless m/^(\S+)\s+(\S+)\s+(\S.*\S)\s*$/;
- ($a,$b,$c)=($1,$2,$3);
- $a =~ y/A-Z/a-z/;
- $pkgsrc{$a}= $c;
- $pkgcomponent{$a}= $b;
- }
- close(MM);
- $_pkgsrc = \%pkgsrc;
- $_pkgcomponent = \%pkgcomponent;
- return $_pkgsrc;
-}
-
-sub getpkgcomponent {
- return $_pkgcomponent if $_pkgcomponent;
- getpkgsrc();
- return $_pkgcomponent;
-}
-
my $_pseudodesc;
sub getpseudodesc {
return $_pseudodesc if $_pseudodesc;
return \%status;
}
-sub getsrcpkgs {
- my $src = shift;
- return () if !$src;
- my %pkgsrc = %{getpkgsrc()};
- my @pkgs;
- foreach ( keys %pkgsrc ) {
- push @pkgs, $_ if $pkgsrc{$_} eq $src;
- }
- return @pkgs;
-}
-
sub buglog {
my $bugnum = shift;
my $location = getbuglocation($bugnum, 'log');
return undef;
}
-# Returns an array of zero or more references to (srcname, srcver) pairs.
-# If $binarch is undef, returns results for all architectures.
-my %_binarytosource;
-sub binarytosource {
- my ($binname, $binver, $binarch) = @_;
-
- # TODO: This gets hit a lot, especially from buggyversion() - probably
- # need an extra cache for speed here.
-
- if (tied %_binarytosource or
- tie %_binarytosource, 'MLDBM', $gBinarySourceMap, O_RDONLY) {
- # avoid autovivification
- if (exists $_binarytosource{$binname} and
- exists $_binarytosource{$binname}{$binver}) {
- if (defined $binarch) {
- my $src = $_binarytosource{$binname}{$binver}{$binarch};
- return () unless defined $src; # not on this arch
- # Copy the data to avoid tiedness problems.
- return [@$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};
- 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
- # version. Try $gPackageSource (unversioned) instead.
- my $pkgsrc = getpkgsrc();
- if (exists $pkgsrc->{$binname}) {
- return [$pkgsrc->{$binname}, $binver];
- } else {
- return ();
- }
-}
-
-# Returns an array of zero or more references to
-# (binname, binver[, binarch]) triplets.
-my %_sourcetobinary;
-sub sourcetobinary {
- my ($srcname, $srcver) = @_;
-
- if (tied %_sourcetobinary or
- tie %_sourcetobinary, 'MLDBM', $gSourceBinaryMap, O_RDONLY) {
- # avoid autovivification
- if (exists $_sourcetobinary{$srcname} and
- exists $_sourcetobinary{$srcname}{$srcver}) {
- my $bin = $_sourcetobinary{$srcname}{$srcver};
- return () unless defined $bin;
- # Copy the data to avoid tiedness problems.
- return @$bin;
- }
- }
-
- # No $gSourceBinaryMap, or it didn't have an entry for this name and
- # version. Try $gPackageSource (unversioned) instead.
- my @srcpkgs = getsrcpkgs($srcname);
- return map [$_, $srcver], @srcpkgs;
-}
-
1;
projects / debbugs.git / commitdiff