1 package Debbugs::Packages;
5 # TODO: move config handling to a separate module
6 my $config_path = '/etc/debbugs';
7 require "$config_path/config";
8 # Allow other modules to load config into their namespace.
9 delete $INC{"$config_path/config"};
12 use vars qw($VERSION @ISA @EXPORT);
18 @EXPORT = qw(getpkgsrc getpkgcomponent getsrcpkgs
19 binarytosource sourcetobinary);
22 use Fcntl qw(O_RDONLY);
23 use MLDBM qw(DB_File);
25 $MLDBM::RemoveTaint = 1;
29 Debbugs::Packages - debbugs binary/source package handling
33 The Debbugs::Packages module provides support functions to map binary
34 packages to their corresponding source packages and vice versa. (This makes
35 sense for software distributions, where developers may work on a single
36 source package which produces several binary packages for use by users; it
37 may not make sense in other contexts.)
45 Returns a reference to a hash of binary package names to their corresponding
53 return $_pkgsrc if $_pkgsrc;
54 return {} unless defined $Debbugs::Packages::gPackageSource;
58 open(MM,"$Debbugs::Packages::gPackageSource")
59 or &quitcgi("open $Debbugs::Packages::gPackageSource: $!");
61 next unless m/^(\S+)\s+(\S+)\s+(\S.*\S)\s*$/;
62 my ($bin,$cmp,$src)=($1,$2,$3);
65 $pkgcomponent{$bin}= $cmp;
69 $_pkgcomponent = \%pkgcomponent;
75 Returns a reference to a hash of binary package names to the component of
76 the archive containing those binary packages (e.g. "main", "contrib",
82 return $_pkgcomponent if $_pkgcomponent;
84 return $_pkgcomponent;
89 Returns a list of the binary packages produced by a given source package.
96 my %pkgsrc = %{getpkgsrc()};
98 foreach ( keys %pkgsrc ) {
99 push @pkgs, $_ if $pkgsrc{$_} eq $src;
106 Returns a reference to the source package name and version pair
107 corresponding to a given binary package name, version, and architecture. If
108 undef is passed as the architecture, returns a list of references to all
109 possible pairs of source package names and versions for all architectures,
110 with any duplicates removed.
116 my ($binname, $binver, $binarch) = @_;
118 # TODO: This gets hit a lot, especially from buggyversion() - probably
119 # need an extra cache for speed here.
121 if (tied %_binarytosource or
122 tie %_binarytosource, 'MLDBM',
123 $Debbugs::Packages::gBinarySourceMap, O_RDONLY) {
124 # avoid autovivification
125 if (exists $_binarytosource{$binname} and
126 exists $_binarytosource{$binname}{$binver}) {
127 if (defined $binarch) {
128 my $src = $_binarytosource{$binname}{$binver}{$binarch};
129 return () unless defined $src; # not on this arch
130 # Copy the data to avoid tiedness problems.
133 # Get (srcname, srcver) pairs for all architectures and
134 # remove any duplicates. This involves some slightly tricky
135 # multidimensional hashing; sorry. Fortunately there'll
136 # usually only be one pair returned.
138 for my $ar (keys %{$_binarytosource{$binname}{$binver}}) {
139 my $src = $_binarytosource{$binname}{$binver}{$ar};
140 next unless defined $src;
141 $uniq{$src->[0]}{$src->[1]} = 1;
144 for my $sn (sort keys %uniq) {
145 push @uniq, [$sn, $_] for sort keys %{$uniq{$sn}};
152 # No $gBinarySourceMap, or it didn't have an entry for this name and
159 Returns a list of references to triplets of binary package names, versions,
160 and architectures corresponding to a given source package name and version.
161 If the given source package name and version cannot be found in the database
162 but the source package name is in the unversioned package-to-source map
163 file, then a reference to a binary package name and version pair will be
164 returned, without the architecture.
170 my ($srcname, $srcver) = @_;
172 if (tied %_sourcetobinary or
173 tie %_sourcetobinary, 'MLDBM',
174 $Debbugs::Packages::gSourceBinaryMap, O_RDONLY) {
175 # avoid autovivification
176 if (exists $_sourcetobinary{$srcname} and
177 exists $_sourcetobinary{$srcname}{$srcver}) {
178 my $bin = $_sourcetobinary{$srcname}{$srcver};
179 return () unless defined $bin;
180 # Copy the data to avoid tiedness problems.
185 # No $gSourceBinaryMap, or it didn't have an entry for this name and
186 # version. Try $gPackageSource (unversioned) instead.
187 my @srcpkgs = getsrcpkgs($srcname);
188 return map [$_, $srcver], @srcpkgs;