1 package Debbugs::Packages;
6 use Debbugs::Config qw(:config :globals);
9 use vars qw($VERSION @EXPORT_OK %EXPORT_TAGS @EXPORT);
15 %EXPORT_TAGS = (versions => [qw(getversions)],
16 mapping => [qw(getpkgsrc getpkgcomponent getsrcpkgs),
17 qw(binarytosource sourcetobinary makesourceversions)
21 Exporter::export_ok_tags(qw(versions mapping));
22 $EXPORT_TAGS{all} = [@EXPORT_OK];
25 use Fcntl qw(O_RDONLY);
26 use MLDBM qw(DB_File Storable);
27 use Storable qw(dclone);
29 $MLDBM::DumpMeth = 'portable';
30 $MLDBM::RemoveTaint = 1;
34 Debbugs::Packages - debbugs binary/source package handling
38 The Debbugs::Packages module provides support functions to map binary
39 packages to their corresponding source packages and vice versa. (This makes
40 sense for software distributions, where developers may work on a single
41 source package which produces several binary packages for use by users; it
42 may not make sense in other contexts.)
50 Returns a reference to a hash of binary package names to their corresponding
59 return $_pkgsrc if $_pkgsrc;
60 return {} unless defined $Debbugs::Packages::gPackageSource;
65 open(MM,"$Debbugs::Packages::gPackageSource")
66 or die("open $Debbugs::Packages::gPackageSource: $!");
68 next unless m/^(\S+)\s+(\S+)\s+(\S.*\S)\s*$/;
69 my ($bin,$cmp,$src)=($1,$2,$3);
72 push @{$srcpkg{$src}}, $bin;
73 $pkgcomponent{$bin}= $cmp;
77 $_pkgcomponent = \%pkgcomponent;
84 Returns a reference to a hash of binary package names to the component of
85 the archive containing those binary packages (e.g. "main", "contrib",
91 return $_pkgcomponent if $_pkgcomponent;
93 return $_pkgcomponent;
98 Returns a list of the binary packages produced by a given source package.
104 getpkgsrc() if not defined $_srcpkg;
105 return () if not defined $src or not exists $_srcpkg->{$src};
106 return @{$_srcpkg->{$src}};
111 Returns a reference to the source package name and version pair
112 corresponding to a given binary package name, version, and architecture. If
113 undef is passed as the architecture, returns a list of references to all
114 possible pairs of source package names and versions for all architectures,
115 with any duplicates removed.
121 my ($binname, $binver, $binarch) = @_;
123 # TODO: This gets hit a lot, especially from buggyversion() - probably
124 # need an extra cache for speed here.
126 if (tied %_binarytosource or
127 tie %_binarytosource, 'MLDBM',
128 $Debbugs::Packages::gBinarySourceMap, O_RDONLY) {
129 # avoid autovivification
130 my $binary = $_binarytosource{$binname};
131 return () unless defined $binary;
132 my %binary = %{$binary};
133 if (exists $binary{$binver}) {
134 if (defined $binarch) {
135 my $src = $binary{$binver}{$binarch};
136 return () unless defined $src; # not on this arch
137 # Copy the data to avoid tiedness problems.
140 # Get (srcname, srcver) pairs for all architectures and
141 # remove any duplicates. This involves some slightly tricky
142 # multidimensional hashing; sorry. Fortunately there'll
143 # usually only be one pair returned.
145 for my $ar (keys %{$binary{$binver}}) {
146 my $src = $binary{$binver}{$ar};
147 next unless defined $src;
148 $uniq{$src->[0]}{$src->[1]} = 1;
151 for my $sn (sort keys %uniq) {
152 push @uniq, [$sn, $_] for sort keys %{$uniq{$sn}};
159 # No $gBinarySourceMap, or it didn't have an entry for this name and
166 Returns a list of references to triplets of binary package names, versions,
167 and architectures corresponding to a given source package name and version.
168 If the given source package name and version cannot be found in the database
169 but the source package name is in the unversioned package-to-source map
170 file, then a reference to a binary package name and version pair will be
171 returned, without the architecture.
177 my ($srcname, $srcver) = @_;
179 if (tied %_sourcetobinary or
180 tie %_sourcetobinary, 'MLDBM',
181 $Debbugs::Packages::gSourceBinaryMap, O_RDONLY) {
182 # avoid autovivification
183 my $source = $_sourcetobinary{$srcname};
184 return () unless defined $source;
185 my %source = %{$source};
186 if (exists $source{$srcver}) {
187 my $bin = $source{$srcver};
188 return () unless defined $bin;
193 # No $gSourceBinaryMap, or it didn't have an entry for this name and
194 # version. Try $gPackageSource (unversioned) instead.
195 my @srcpkgs = getsrcpkgs($srcname);
196 return map [$_, $srcver], @srcpkgs;
201 Returns versions of the package in a distribution at a specific
208 my ($pkg, $dist, $arch) = @_;
209 return () unless defined $gVersionIndex;
210 $dist = 'unstable' unless defined $dist;
212 unless (tied %_versions) {
213 tie %_versions, 'MLDBM', $gVersionIndex, O_RDONLY
214 or die "can't open versions index: $!";
216 my $version = $_versions{$pkg};
217 return () unless defined $version;
218 my %version = %{$version};
220 if (defined $arch and exists $version{$dist}{$arch}) {
221 my $ver = $version{$pkg}{$dist}{$arch};
222 return $ver if defined $ver;
226 for my $ar (keys %{$version{$dist}}) {
227 $uniq{$version{$dist}{$ar}} = 1 unless $ar eq 'source';
231 } elsif (exists $version{$dist}{source}) {
232 # Maybe this is actually a source package with no corresponding
234 return $version{$dist}{source};
242 =item makesourceversions
244 @{$cgi_var{found}} = makesourceversions($cgi_var{package},undef,@{$cgi_var{found}});
246 Canonicalize versions into source versions, which have an explicitly
247 named source package. This is used to cope with source packages whose
248 names have changed during their history, and with cases where source
249 version numbers differ from binary version numbers.
253 my %_sourceversioncache = ();
254 sub makesourceversions {
259 for my $version (@_) {
260 if ($version =~ m[/]) {
261 # Already a source version.
262 $sourceversions{$version} = 1;
264 my $cachearch = (defined $arch) ? $arch : '';
265 my $cachekey = "$pkg/$cachearch/$version";
266 if (exists($_sourceversioncache{$cachekey})) {
267 for my $v (@{$_sourceversioncache{$cachekey}}) {
268 $sourceversions{$v} = 1;
273 my @srcinfo = binarytosource($pkg, $version, $arch);
275 # We don't have explicit information about the
276 # binary-to-source mapping for this version (yet). Since
277 # this is a CGI script and our output is transient, we can
278 # get away with just looking in the unversioned map; if it's
279 # wrong (as it will be when binary and source package
280 # versions differ), too bad.
281 my $pkgsrc = getpkgsrc();
282 if (exists $pkgsrc->{$pkg}) {
283 @srcinfo = ([$pkgsrc->{$pkg}, $version]);
284 } elsif (getsrcpkgs($pkg)) {
285 # If we're looking at a source package that doesn't have
286 # a binary of the same name, just try the same version.
287 @srcinfo = ([$pkg, $version]);
292 $sourceversions{"$_->[0]/$_->[1]"} = 1 foreach @srcinfo;
293 $_sourceversioncache{$cachekey} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
297 return sort keys %sourceversions;