1 # This module is part of debbugs, and is released
2 # under the terms of the GPL version 2, or any later
3 # version at your option.
4 # See the file README and COPYING for more information.
6 # [Other people have contributed to this file; their copyrights should
8 # Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
10 package Debbugs::Packages;
15 use Debbugs::Config qw(:config :globals);
17 use base qw(Exporter);
18 use vars qw($VERSION @EXPORT_OK %EXPORT_TAGS @EXPORT);
24 %EXPORT_TAGS = (versions => [qw(getversions get_versions)],
25 mapping => [qw(getpkgsrc getpkgcomponent getsrcpkgs),
26 qw(binarytosource sourcetobinary makesourceversions)
30 Exporter::export_ok_tags(qw(versions mapping));
31 $EXPORT_TAGS{all} = [@EXPORT_OK];
34 use Fcntl qw(O_RDONLY);
35 use MLDBM qw(DB_File Storable);
36 use Storable qw(dclone);
37 use Params::Validate qw(validate_with :types);
38 use Debbugs::Common qw(make_list);
40 use List::Util qw(min max);
42 $MLDBM::DumpMeth = 'portable';
43 $MLDBM::RemoveTaint = 1;
47 Debbugs::Packages - debbugs binary/source package handling
51 The Debbugs::Packages module provides support functions to map binary
52 packages to their corresponding source packages and vice versa. (This makes
53 sense for software distributions, where developers may work on a single
54 source package which produces several binary packages for use by users; it
55 may not make sense in other contexts.)
63 Returns a reference to a hash of binary package names to their corresponding
72 return $_pkgsrc if $_pkgsrc;
73 return {} unless defined $Debbugs::Packages::gPackageSource;
78 open(MM,"$Debbugs::Packages::gPackageSource")
79 or die("open $Debbugs::Packages::gPackageSource: $!");
81 next unless m/^(\S+)\s+(\S+)\s+(\S.*\S)\s*$/;
82 my ($bin,$cmp,$src)=($1,$2,$3);
85 push @{$srcpkg{$src}}, $bin;
86 $pkgcomponent{$bin}= $cmp;
90 $_pkgcomponent = \%pkgcomponent;
97 Returns a reference to a hash of binary package names to the component of
98 the archive containing those binary packages (e.g. "main", "contrib",
103 sub getpkgcomponent {
104 return $_pkgcomponent if $_pkgcomponent;
106 return $_pkgcomponent;
111 Returns a list of the binary packages produced by a given source package.
117 getpkgsrc() if not defined $_srcpkg;
118 return () if not defined $src or not exists $_srcpkg->{$src};
119 return @{$_srcpkg->{$src}};
124 Returns a reference to the source package name and version pair
125 corresponding to a given binary package name, version, and architecture.
127 If undef is passed as the architecture, returns a list of references
128 to all possible pairs of source package names and versions for all
129 architectures, with any duplicates removed.
131 If the binary version is not passed either, returns a list of possible
132 source package names for all architectures at all versions, with any
137 our %_binarytosource;
139 my ($binname, $binver, $binarch) = @_;
141 # TODO: This gets hit a lot, especially from buggyversion() - probably
142 # need an extra cache for speed here.
143 return () unless defined $gBinarySourceMap;
145 if (not tied %_binarytosource) {
146 tie %_binarytosource, MLDBM => $gBinarySourceMap, O_RDONLY or
147 die "Unable to open $gBinarySourceMap for reading";
150 # avoid autovivification
151 my $binary = $_binarytosource{$binname};
152 return () unless defined $binary;
153 my %binary = %{$binary};
154 if (not defined $binver) {
156 for my $ver (keys %binary) {
157 for my $ar (keys %{$binary{$binver}}) {
158 my $src = $binary{$binver}{$ar};
159 next unless defined $src;
160 $uniq{$src->[0]} = 1;
165 elsif (exists $binary{$binver}) {
166 if (defined $binarch) {
167 my $src = $binary{$binver}{$binarch};
168 return () unless defined $src; # not on this arch
169 # Copy the data to avoid tiedness problems.
172 # Get (srcname, srcver) pairs for all architectures and
173 # remove any duplicates. This involves some slightly tricky
174 # multidimensional hashing; sorry. Fortunately there'll
175 # usually only be one pair returned.
177 for my $ar (keys %{$binary{$binver}}) {
178 my $src = $binary{$binver}{$ar};
179 next unless defined $src;
180 $uniq{$src->[0]}{$src->[1]} = 1;
183 for my $sn (sort keys %uniq) {
184 push @uniq, [$sn, $_] for sort keys %{$uniq{$sn}};
190 # No $gBinarySourceMap, or it didn't have an entry for this name and
197 Returns a list of references to triplets of binary package names, versions,
198 and architectures corresponding to a given source package name and version.
199 If the given source package name and version cannot be found in the database
200 but the source package name is in the unversioned package-to-source map
201 file, then a reference to a binary package name and version pair will be
202 returned, without the architecture.
206 our %_sourcetobinary;
208 my ($srcname, $srcver) = @_;
210 if (not tied %_sourcetobinary) {
211 tie %_sourcetobinary, MLDBM => $gSourceBinaryMap, O_RDONLY or
212 die "Unable top open $gSourceBinaryMap for reading";
217 # avoid autovivification
218 my $source = $_sourcetobinary{$srcname};
219 return () unless defined $source;
220 my %source = %{$source};
221 if (exists $source{$srcver}) {
222 my $bin = $source{$srcver};
223 return () unless defined $bin;
226 # No $gSourceBinaryMap, or it didn't have an entry for this name and
227 # version. Try $gPackageSource (unversioned) instead.
228 my @srcpkgs = getsrcpkgs($srcname);
229 return map [$_, $srcver], @srcpkgs;
234 Returns versions of the package in a distribution at a specific
240 my ($pkg, $dist, $arch) = @_;
241 return get_versions(package=>$pkg,
243 defined $arch ? (arch => $arch):(),
251 get_versions(package=>'foopkg',
256 Returns a list of the versions of package in the distributions and
257 architectures listed. This routine only returns unique values.
261 =item package -- package to return list of versions
263 =item dist -- distribution (unstable, stable, testing); can be an
266 =item arch -- architecture (i386, source, ...); can be an arrayref
268 =item time -- returns a version=>time hash at which the newest package
269 matching this version was uploaded
271 =item source -- returns source/version instead of just versions
273 =item no_source_arch -- discards the source architecture when arch is
274 not passed. [Used for finding the versions of binary packages only.]
275 Defaults to 0, which does not discard the source architecture. (This
276 may change in the future, so if you care, please code accordingly.)
278 =item return_archs -- returns a version=>[archs] hash indicating which
279 architectures are at which versions.
283 When called in scalar context, this function will return hashrefs or
284 arrayrefs as appropriate, in list context, it will return paired lists
285 or unpaired lists as appropriate.
293 my %param = validate_with(params => \@_,
294 spec => {package => {type => SCALAR|ARRAYREF,
296 dist => {type => SCALAR|ARRAYREF,
297 default => 'unstable',
299 arch => {type => SCALAR|ARRAYREF,
302 time => {type => BOOLEAN,
305 source => {type => BOOLEAN,
308 no_source_arch => {type => BOOLEAN,
311 return_archs => {type => BOOLEAN,
318 return () if not defined $gVersionTimeIndex;
319 unless (tied %_versions_time) {
320 tie %_versions_time, 'MLDBM', $gVersionTimeIndex, O_RDONLY
321 or die "can't open versions index $gVersionTimeIndex: $!";
323 $versions = \%_versions_time;
326 return () if not defined $gVersionIndex;
327 unless (tied %_versions) {
328 tie %_versions, 'MLDBM', $gVersionIndex, O_RDONLY
329 or die "can't open versions index $gVersionIndex: $!";
331 $versions = \%_versions;
334 for my $package (make_list($param{package})) {
335 my $version = $versions->{$package};
336 next unless defined $version;
337 for my $dist (make_list($param{dist})) {
338 for my $arch (exists $param{arch}?
339 make_list($param{arch}):
340 (grep {not $param{no_source_arch} or
342 } keys %{$version->{$dist}})) {
343 next unless defined $version->{$dist}{$arch};
344 for my $ver (ref $version->{$dist}{$arch} ?
345 keys %{$version->{$dist}{$arch}} :
346 $version->{$dist}{$arch}
349 if ($param{source}) {
350 ($f_ver) = makesourceversions($package,$arch,$ver);
351 next unless defined $f_ver;
354 $versions{$f_ver} = max($versions{$f_ver}||0,$version->{$dist}{$arch}{$ver});
357 push @{$versions{$f_ver}},$arch;
363 if ($param{time} or $param{return_archs}) {
364 return wantarray?%versions :\%versions;
366 return wantarray?keys %versions :[keys %versions];
370 =item makesourceversions
372 @{$cgi_var{found}} = makesourceversions($cgi_var{package},undef,@{$cgi_var{found}});
374 Canonicalize versions into source versions, which have an explicitly
375 named source package. This is used to cope with source packages whose
376 names have changed during their history, and with cases where source
377 version numbers differ from binary version numbers.
381 our %_sourceversioncache = ();
382 sub makesourceversions {
386 die "Package $pkg is multiple packages; split on , and call makesourceversions multiple times"
389 for my $version (@_) {
390 if ($version =~ m[/]) {
391 # Already a source version.
392 $sourceversions{$version} = 1;
394 my $cachearch = (defined $arch) ? $arch : '';
395 my $cachekey = "$pkg/$cachearch/$version";
396 if (exists($_sourceversioncache{$cachekey})) {
397 for my $v (@{$_sourceversioncache{$cachekey}}) {
398 $sourceversions{$v} = 1;
403 my @srcinfo = binarytosource($pkg, $version, $arch);
405 # We don't have explicit information about the
406 # binary-to-source mapping for this version (yet). Since
407 # this is a CGI script and our output is transient, we can
408 # get away with just looking in the unversioned map; if it's
409 # wrong (as it will be when binary and source package
410 # versions differ), too bad.
411 my $pkgsrc = getpkgsrc();
412 if (exists $pkgsrc->{$pkg}) {
413 @srcinfo = ([$pkgsrc->{$pkg}, $version]);
414 } elsif (getsrcpkgs($pkg)) {
415 # If we're looking at a source package that doesn't have
416 # a binary of the same name, just try the same version.
417 @srcinfo = ([$pkg, $version]);
422 $sourceversions{"$_->[0]/$_->[1]"} = 1 foreach @srcinfo;
423 $_sourceversioncache{$cachekey} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
427 return sort keys %sourceversions;