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 (not tied %_binarytosource) {
148 tie %_binarytosource, MLDBM => $gBinarySourceMap, O_RDONLY or
149 die "Unable to open $gBinarySourceMap for reading";
152 # avoid autovivification
153 my $binary = $_binarytosource{$binname};
154 return () unless defined $binary;
155 my %binary = %{$binary};
156 if (not defined $binver) {
158 for my $ver (keys %binary) {
159 for my $ar (keys %{$binary{$ver}}) {
160 my $src = $binary{$ver}{$ar};
161 next unless defined $src;
162 $uniq{$src->[0]} = 1;
167 elsif (exists $binary{$binver}) {
168 if (defined $binarch) {
169 my $src = $binary{$binver}{$binarch};
170 if (not defined $src and exists $binary{$binver}{all}) {
171 $src = $binary{$binver}{all};
173 return () unless defined $src; # not on this arch
174 # Copy the data to avoid tiedness problems.
177 # Get (srcname, srcver) pairs for all architectures and
178 # remove any duplicates. This involves some slightly tricky
179 # multidimensional hashing; sorry. Fortunately there'll
180 # usually only be one pair returned.
182 for my $ar (keys %{$binary{$binver}}) {
183 my $src = $binary{$binver}{$ar};
184 next unless defined $src;
185 $uniq{$src->[0]}{$src->[1]} = 1;
188 for my $sn (sort keys %uniq) {
189 push @uniq, [$sn, $_] for sort keys %{$uniq{$sn}};
195 # No $gBinarySourceMap, or it didn't have an entry for this name and
200 =head2 sourcetobinary
202 Returns a list of references to triplets of binary package names, versions,
203 and architectures corresponding to a given source package name and version.
204 If the given source package name and version cannot be found in the database
205 but the source package name is in the unversioned package-to-source map
206 file, then a reference to a binary package name and version pair will be
207 returned, without the architecture.
211 our %_sourcetobinary;
213 my ($srcname, $srcver) = @_;
215 if (not tied %_sourcetobinary) {
216 tie %_sourcetobinary, MLDBM => $gSourceBinaryMap, O_RDONLY or
217 die "Unable top open $gSourceBinaryMap for reading";
222 # avoid autovivification
223 my $source = $_sourcetobinary{$srcname};
224 return () unless defined $source;
225 if (exists $source->{$srcver}) {
226 my $bin = $source->{$srcver};
227 return () unless defined $bin;
230 # No $gSourceBinaryMap, or it didn't have an entry for this name and
231 # version. Try $gPackageSource (unversioned) instead.
232 my @srcpkgs = getsrcpkgs($srcname);
233 return map [$_, $srcver], @srcpkgs;
238 Returns versions of the package in a distribution at a specific
244 my ($pkg, $dist, $arch) = @_;
245 return get_versions(package=>$pkg,
247 defined $arch ? (arch => $arch):(),
255 get_versions(package=>'foopkg',
260 Returns a list of the versions of package in the distributions and
261 architectures listed. This routine only returns unique values.
265 =item package -- package to return list of versions
267 =item dist -- distribution (unstable, stable, testing); can be an
270 =item arch -- architecture (i386, source, ...); can be an arrayref
272 =item time -- returns a version=>time hash at which the newest package
273 matching this version was uploaded
275 =item source -- returns source/version instead of just versions
277 =item no_source_arch -- discards the source architecture when arch is
278 not passed. [Used for finding the versions of binary packages only.]
279 Defaults to 0, which does not discard the source architecture. (This
280 may change in the future, so if you care, please code accordingly.)
282 =item return_archs -- returns a version=>[archs] hash indicating which
283 architectures are at which versions.
287 When called in scalar context, this function will return hashrefs or
288 arrayrefs as appropriate, in list context, it will return paired lists
289 or unpaired lists as appropriate.
297 my %param = validate_with(params => \@_,
298 spec => {package => {type => SCALAR|ARRAYREF,
300 dist => {type => SCALAR|ARRAYREF,
301 default => 'unstable',
303 arch => {type => SCALAR|ARRAYREF,
306 time => {type => BOOLEAN,
309 source => {type => BOOLEAN,
312 no_source_arch => {type => BOOLEAN,
315 return_archs => {type => BOOLEAN,
322 return () if not defined $gVersionTimeIndex;
323 unless (tied %_versions_time) {
324 tie %_versions_time, 'MLDBM', $gVersionTimeIndex, O_RDONLY
325 or die "can't open versions index $gVersionTimeIndex: $!";
327 $versions = \%_versions_time;
330 return () if not defined $gVersionIndex;
331 unless (tied %_versions) {
332 tie %_versions, 'MLDBM', $gVersionIndex, O_RDONLY
333 or die "can't open versions index $gVersionIndex: $!";
335 $versions = \%_versions;
338 for my $package (make_list($param{package})) {
339 my $version = $versions->{$package};
340 next unless defined $version;
341 for my $dist (make_list($param{dist})) {
342 for my $arch (exists $param{arch}?
343 make_list($param{arch}):
344 (grep {not $param{no_source_arch} or
346 } keys %{$version->{$dist}})) {
347 next unless defined $version->{$dist}{$arch};
348 for my $ver (ref $version->{$dist}{$arch} ?
349 keys %{$version->{$dist}{$arch}} :
350 $version->{$dist}{$arch}
353 if ($param{source}) {
354 ($f_ver) = make_source_versions(package => $package,
357 next unless defined $f_ver;
360 $versions{$f_ver} = max($versions{$f_ver}||0,$version->{$dist}{$arch}{$ver});
363 push @{$versions{$f_ver}},$arch;
369 if ($param{time} or $param{return_archs}) {
370 return wantarray?%versions :\%versions;
372 return wantarray?keys %versions :[keys %versions];
376 =head2 makesourceversions
378 @{$cgi_var{found}} = makesourceversions($cgi_var{package},undef,@{$cgi_var{found}});
380 Canonicalize versions into source versions, which have an explicitly
381 named source package. This is used to cope with source packages whose
382 names have changed during their history, and with cases where source
383 version numbers differ from binary version numbers.
387 our %_sourceversioncache = ();
388 sub makesourceversions {
389 my ($package,$arch,@versions) = @_;
390 die "Package $package is multiple packages; split on , and call makesourceversions multiple times"
392 return make_source_versions(package => $package,
393 (defined $arch)?(arch => $arch):(),
394 versions => \@versions
398 =head2 make_source_versions
400 make_source_versions(package => 'foo',
405 warnings => \$warnings,
408 An extended version of makesourceversions (which calls this function
409 internally) that allows for multiple packages, architectures, and
410 outputs warnings and debugging information to provided SCALARREFs or
413 The guess_source option determines whether the source package is
414 guessed at if there is no obviously correct package. Things that use
415 this function for non-transient output should set this to false,
416 things that use it for transient output can set this to true.
417 Currently it defaults to true, but that is not a sane option.
422 sub make_source_versions {
423 my %param = validate_with(params => \@_,
424 spec => {package => {type => SCALAR|ARRAYREF,
426 arch => {type => SCALAR|ARRAYREF|UNDEF,
429 versions => {type => SCALAR|ARRAYREF,
432 guess_source => {type => BOOLEAN,
435 source_version_cache => {type => HASHREF,
438 debug => {type => SCALARREF|HANDLE,
441 warnings => {type => SCALARREF|HANDLE,
446 my ($warnings) = globify_scalar(exists $param{warnings}?$param{warnings}:undef);
447 my ($debug) = globify_scalar(exists $param{debug} ?$param{debug} :undef);
449 my @packages = grep {defined $_ and length $_ } make_list($param{package});
450 my @archs = grep {defined $_ } make_list ($param{arch});
454 if (not exists $param{source_version_cache}) {
455 $param{source_version_cache} = \%_sourceversioncache;
457 if (grep {/,/} make_list($param{package})) {
458 croak "Package names contain ,; split on /,/ and call make_source_versions with an arrayref of packages"
461 for my $version (make_list($param{versions})) {
462 if ($version =~ m{(.+)/([^/]+)$}) {
463 # check to see if this source version is even possible
464 my @bin_versions = sourcetobinary($1,$2);
465 if (not @bin_versions or
466 @{$bin_versions[0]} != 3) {
467 print {$warnings} "The source $1 and version $2 do not appear to match any binary packages\n";
469 # Already a source version.
470 $sourceversions{$version} = 1;
473 croak "You must provide at least one package if the versions are not fully qualified";
475 for my $pkg (@packages) {
476 for my $arch (@archs) {
477 my $cachearch = (defined $arch) ? $arch : '';
478 my $cachekey = "$pkg/$cachearch/$version";
479 if (exists($param{source_version_cache}{$cachekey})) {
480 for my $v (@{$param{source_version_cache}{$cachekey}}) {
481 $sourceversions{$v} = 1;
485 elsif ($param{guess_source} and
486 exists$param{source_version_cache}{$cachekey.'/guess'}) {
487 for my $v (@{$param{source_version_cache}{$cachekey.'/guess'}}) {
488 $sourceversions{$v} = 1;
492 my @srcinfo = binarytosource($pkg, $version, $arch);
494 # We don't have explicit information about the
495 # binary-to-source mapping for this version
497 print {$warnings} "There is no source info for the package '$pkg' at version '$version' with architecture '$arch'\n";
498 if ($param{guess_source}) {
500 my $pkgsrc = getpkgsrc();
501 if (exists $pkgsrc->{$pkg}) {
502 @srcinfo = ([$pkgsrc->{$pkg}, $version]);
503 } elsif (getsrcpkgs($pkg)) {
504 # If we're looking at a source package
505 # that doesn't have a binary of the
506 # same name, just try the same
508 @srcinfo = ([$pkg, $version]);
512 # store guesses in a slightly different location
513 $param{source_version_cache}{$cachekey.'/guess'} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
517 # only store this if we didn't have to guess it
518 $param{source_version_cache}{$cachekey} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
520 $sourceversions{"$_->[0]/$_->[1]"} = 1 foreach @srcinfo;
525 return sort keys %sourceversions;