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 base qw(Exporter);
16 use vars qw($VERSION @EXPORT_OK %EXPORT_TAGS @EXPORT);
20 use Debbugs::Config qw(:config :globals);
26 %EXPORT_TAGS = (versions => [qw(getversions get_versions make_source_versions)],
27 mapping => [qw(getpkgsrc getpkgcomponent getsrcpkgs),
28 qw(binarytosource sourcetobinary makesourceversions)
32 Exporter::export_ok_tags(qw(versions mapping));
33 $EXPORT_TAGS{all} = [@EXPORT_OK];
36 use Fcntl qw(O_RDONLY);
37 use MLDBM qw(DB_File Storable);
38 use Storable qw(dclone);
39 use Params::Validate qw(validate_with :types);
40 use Debbugs::Common qw(make_list globify_scalar);
42 use List::Util qw(min max);
46 $MLDBM::DumpMeth = 'portable';
47 $MLDBM::RemoveTaint = 1;
51 Debbugs::Packages - debbugs binary/source package handling
55 The Debbugs::Packages module provides support functions to map binary
56 packages to their corresponding source packages and vice versa. (This makes
57 sense for software distributions, where developers may work on a single
58 source package which produces several binary packages for use by users; it
59 may not make sense in other contexts.)
65 Returns a reference to a hash of binary package names to their corresponding
74 return $_pkgsrc if $_pkgsrc;
75 return {} unless defined $Debbugs::Packages::gPackageSource;
80 my $fh = IO::File->new($config{package_source},'r')
81 or die("Unable to open $config{package_source} for reading: $!");
83 next unless m/^(\S+)\s+(\S+)\s+(\S.*\S)\s*$/;
84 my ($bin,$cmp,$src)=($1,$2,$3);
87 push @{$srcpkg{$src}}, $bin;
88 $pkgcomponent{$bin}= $cmp;
92 $_pkgcomponent = \%pkgcomponent;
97 =head2 getpkgcomponent
99 Returns a reference to a hash of binary package names to the component of
100 the archive containing those binary packages (e.g. "main", "contrib",
105 sub getpkgcomponent {
106 return $_pkgcomponent if $_pkgcomponent;
108 return $_pkgcomponent;
113 Returns a list of the binary packages produced by a given source package.
119 getpkgsrc() if not defined $_srcpkg;
120 return () if not defined $src or not exists $_srcpkg->{$src};
121 return @{$_srcpkg->{$src}};
124 =head2 binarytosource
126 Returns a reference to the source package name and version pair
127 corresponding to a given binary package name, version, and architecture.
129 If undef is passed as the architecture, returns a list of references
130 to all possible pairs of source package names and versions for all
131 architectures, with any duplicates removed.
133 If the binary version is not passed either, returns a list of possible
134 source package names for all architectures at all versions, with any
139 our %_binarytosource;
141 my ($binname, $binver, $binarch) = @_;
143 # TODO: This gets hit a lot, especially from buggyversion() - probably
144 # need an extra cache for speed here.
145 return () unless defined $gBinarySourceMap;
147 if ($binname =~ m/^src:(.+)$/) {
150 if (not tied %_binarytosource) {
151 tie %_binarytosource, MLDBM => $gBinarySourceMap, O_RDONLY or
152 die "Unable to open $gBinarySourceMap for reading";
155 # avoid autovivification
156 my $binary = $_binarytosource{$binname};
157 return () unless defined $binary;
158 my %binary = %{$binary};
159 if (not defined $binver) {
161 for my $ver (keys %binary) {
162 for my $ar (keys %{$binary{$ver}}) {
163 my $src = $binary{$ver}{$ar};
164 next unless defined $src;
165 $uniq{$src->[0]} = 1;
170 elsif (exists $binary{$binver}) {
171 if (defined $binarch) {
172 my $src = $binary{$binver}{$binarch};
173 if (not defined $src and exists $binary{$binver}{all}) {
174 $src = $binary{$binver}{all};
176 return () unless defined $src; # not on this arch
177 # Copy the data to avoid tiedness problems.
180 # Get (srcname, srcver) pairs for all architectures and
181 # remove any duplicates. This involves some slightly tricky
182 # multidimensional hashing; sorry. Fortunately there'll
183 # usually only be one pair returned.
185 for my $ar (keys %{$binary{$binver}}) {
186 my $src = $binary{$binver}{$ar};
187 next unless defined $src;
188 $uniq{$src->[0]}{$src->[1]} = 1;
191 for my $sn (sort keys %uniq) {
192 push @uniq, [$sn, $_] for sort keys %{$uniq{$sn}};
198 # No $gBinarySourceMap, or it didn't have an entry for this name and
203 =head2 sourcetobinary
205 Returns a list of references to triplets of binary package names, versions,
206 and architectures corresponding to a given source package name and version.
207 If the given source package name and version cannot be found in the database
208 but the source package name is in the unversioned package-to-source map
209 file, then a reference to a binary package name and version pair will be
210 returned, without the architecture.
214 our %_sourcetobinary;
216 my ($srcname, $srcver) = @_;
218 if (not tied %_sourcetobinary) {
219 tie %_sourcetobinary, MLDBM => $gSourceBinaryMap, O_RDONLY or
220 die "Unable top open $gSourceBinaryMap for reading";
225 # avoid autovivification
226 my $source = $_sourcetobinary{$srcname};
227 return () unless defined $source;
228 if (exists $source->{$srcver}) {
229 my $bin = $source->{$srcver};
230 return () unless defined $bin;
233 # No $gSourceBinaryMap, or it didn't have an entry for this name and
234 # version. Try $gPackageSource (unversioned) instead.
235 my @srcpkgs = getsrcpkgs($srcname);
236 return map [$_, $srcver], @srcpkgs;
241 Returns versions of the package in a distribution at a specific
247 my ($pkg, $dist, $arch) = @_;
248 return get_versions(package=>$pkg,
250 defined $arch ? (arch => $arch):(),
258 get_versions(package=>'foopkg',
263 Returns a list of the versions of package in the distributions and
264 architectures listed. This routine only returns unique values.
268 =item package -- package to return list of versions
270 =item dist -- distribution (unstable, stable, testing); can be an
273 =item arch -- architecture (i386, source, ...); can be an arrayref
275 =item time -- returns a version=>time hash at which the newest package
276 matching this version was uploaded
278 =item source -- returns source/version instead of just versions
280 =item no_source_arch -- discards the source architecture when arch is
281 not passed. [Used for finding the versions of binary packages only.]
282 Defaults to 0, which does not discard the source architecture. (This
283 may change in the future, so if you care, please code accordingly.)
285 =item return_archs -- returns a version=>[archs] hash indicating which
286 architectures are at which versions.
290 When called in scalar context, this function will return hashrefs or
291 arrayrefs as appropriate, in list context, it will return paired lists
292 or unpaired lists as appropriate.
300 my %param = validate_with(params => \@_,
301 spec => {package => {type => SCALAR|ARRAYREF,
303 dist => {type => SCALAR|ARRAYREF,
304 default => 'unstable',
306 arch => {type => SCALAR|ARRAYREF,
309 time => {type => BOOLEAN,
312 source => {type => BOOLEAN,
315 no_source_arch => {type => BOOLEAN,
318 return_archs => {type => BOOLEAN,
325 return () if not defined $gVersionTimeIndex;
326 unless (tied %_versions_time) {
327 tie %_versions_time, 'MLDBM', $gVersionTimeIndex, O_RDONLY
328 or die "can't open versions index $gVersionTimeIndex: $!";
330 $versions = \%_versions_time;
333 return () if not defined $gVersionIndex;
334 unless (tied %_versions) {
335 tie %_versions, 'MLDBM', $gVersionIndex, O_RDONLY
336 or die "can't open versions index $gVersionIndex: $!";
338 $versions = \%_versions;
341 for my $package (make_list($param{package})) {
342 my $version = $versions->{$package};
343 next unless defined $version;
344 for my $dist (make_list($param{dist})) {
345 for my $arch (exists $param{arch}?
346 make_list($param{arch}):
347 (grep {not $param{no_source_arch} or
349 } keys %{$version->{$dist}})) {
350 next unless defined $version->{$dist}{$arch};
351 for my $ver (ref $version->{$dist}{$arch} ?
352 keys %{$version->{$dist}{$arch}} :
353 $version->{$dist}{$arch}
356 if ($param{source}) {
357 ($f_ver) = make_source_versions(package => $package,
360 next unless defined $f_ver;
363 $versions{$f_ver} = max($versions{$f_ver}||0,$version->{$dist}{$arch}{$ver});
366 push @{$versions{$f_ver}},$arch;
372 if ($param{time} or $param{return_archs}) {
373 return wantarray?%versions :\%versions;
375 return wantarray?keys %versions :[keys %versions];
379 =head2 makesourceversions
381 @{$cgi_var{found}} = makesourceversions($cgi_var{package},undef,@{$cgi_var{found}});
383 Canonicalize versions into source versions, which have an explicitly
384 named source package. This is used to cope with source packages whose
385 names have changed during their history, and with cases where source
386 version numbers differ from binary version numbers.
390 our %_sourceversioncache = ();
391 sub makesourceversions {
392 my ($package,$arch,@versions) = @_;
393 die "Package $package is multiple packages; split on , and call makesourceversions multiple times"
395 return make_source_versions(package => $package,
396 (defined $arch)?(arch => $arch):(),
397 versions => \@versions
401 =head2 make_source_versions
403 make_source_versions(package => 'foo',
408 warnings => \$warnings,
411 An extended version of makesourceversions (which calls this function
412 internally) that allows for multiple packages, architectures, and
413 outputs warnings and debugging information to provided SCALARREFs or
416 The guess_source option determines whether the source package is
417 guessed at if there is no obviously correct package. Things that use
418 this function for non-transient output should set this to false,
419 things that use it for transient output can set this to true.
420 Currently it defaults to true, but that is not a sane option.
425 sub make_source_versions {
426 my %param = validate_with(params => \@_,
427 spec => {package => {type => SCALAR|ARRAYREF,
429 arch => {type => SCALAR|ARRAYREF|UNDEF,
432 versions => {type => SCALAR|ARRAYREF,
435 guess_source => {type => BOOLEAN,
438 source_version_cache => {type => HASHREF,
441 debug => {type => SCALARREF|HANDLE,
444 warnings => {type => SCALARREF|HANDLE,
449 my ($warnings) = globify_scalar(exists $param{warnings}?$param{warnings}:undef);
450 my ($debug) = globify_scalar(exists $param{debug} ?$param{debug} :undef);
452 my @packages = grep {defined $_ and length $_ } make_list($param{package});
453 my @archs = grep {defined $_ } make_list ($param{arch});
457 if (not exists $param{source_version_cache}) {
458 $param{source_version_cache} = \%_sourceversioncache;
460 if (grep {/,/} make_list($param{package})) {
461 croak "Package names contain ,; split on /,/ and call make_source_versions with an arrayref of packages"
464 for my $version (make_list($param{versions})) {
465 if ($version =~ m{(.+)/([^/]+)$}) {
466 # Already a source version.
467 $sourceversions{$version} = 1;
468 next unless exists $param{warnings};
469 # check to see if this source version is even possible
470 my @bin_versions = sourcetobinary($1,$2);
471 if (not @bin_versions or
472 @{$bin_versions[0]} != 3) {
473 print {$warnings} "The source $1 and version $2 do not appear to match any binary packages\n";
477 croak "You must provide at least one package if the versions are not fully qualified";
479 for my $pkg (@packages) {
480 if ($pkg =~ /^src:(.+)/) {
481 $sourceversions{"$1/$version"} = 1;
482 next unless exists $param{warnings};
483 # check to see if this source version is even possible
484 my @bin_versions = sourcetobinary($1,$version);
485 if (not @bin_versions or
486 @{$bin_versions[0]} != 3) {
487 print {$warnings} "The source $1 and version $2 do not appear to match any binary packages\n";
491 for my $arch (@archs) {
492 my $cachearch = (defined $arch) ? $arch : '';
493 my $cachekey = "$pkg/$cachearch/$version";
494 if (exists($param{source_version_cache}{$cachekey})) {
495 for my $v (@{$param{source_version_cache}{$cachekey}}) {
496 $sourceversions{$v} = 1;
500 elsif ($param{guess_source} and
501 exists$param{source_version_cache}{$cachekey.'/guess'}) {
502 for my $v (@{$param{source_version_cache}{$cachekey.'/guess'}}) {
503 $sourceversions{$v} = 1;
507 my @srcinfo = binarytosource($pkg, $version, $arch);
509 # We don't have explicit information about the
510 # binary-to-source mapping for this version
512 print {$warnings} "There is no source info for the package '$pkg' at version '$version' with architecture '$arch'\n";
513 if ($param{guess_source}) {
515 my $pkgsrc = getpkgsrc();
516 if (exists $pkgsrc->{$pkg}) {
517 @srcinfo = ([$pkgsrc->{$pkg}, $version]);
518 } elsif (getsrcpkgs($pkg)) {
519 # If we're looking at a source package
520 # that doesn't have a binary of the
521 # same name, just try the same
523 @srcinfo = ([$pkg, $version]);
527 # store guesses in a slightly different location
528 $param{source_version_cache}{$cachekey.'/guess'} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
532 # only store this if we didn't have to guess it
533 $param{source_version_cache}{$cachekey} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
535 $sourceversions{"$_->[0]/$_->[1]"} = 1 foreach @srcinfo;
540 return sort keys %sourceversions;