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.)
67 Returns a reference to a hash of binary package names to their corresponding
76 return $_pkgsrc if $_pkgsrc;
77 return {} unless defined $Debbugs::Packages::gPackageSource;
82 my $fh = IO::File->new($config{package_source},'r')
83 or die("Unable to open $config{package_source} for reading: $!");
85 next unless m/^(\S+)\s+(\S+)\s+(\S.*\S)\s*$/;
86 my ($bin,$cmp,$src)=($1,$2,$3);
89 push @{$srcpkg{$src}}, $bin;
90 $pkgcomponent{$bin}= $cmp;
94 $_pkgcomponent = \%pkgcomponent;
101 Returns a reference to a hash of binary package names to the component of
102 the archive containing those binary packages (e.g. "main", "contrib",
107 sub getpkgcomponent {
108 return $_pkgcomponent if $_pkgcomponent;
110 return $_pkgcomponent;
115 Returns a list of the binary packages produced by a given source package.
121 getpkgsrc() if not defined $_srcpkg;
122 return () if not defined $src or not exists $_srcpkg->{$src};
123 return @{$_srcpkg->{$src}};
128 Returns a reference to the source package name and version pair
129 corresponding to a given binary package name, version, and architecture.
131 If undef is passed as the architecture, returns a list of references
132 to all possible pairs of source package names and versions for all
133 architectures, with any duplicates removed.
135 If the binary version is not passed either, returns a list of possible
136 source package names for all architectures at all versions, with any
141 our %_binarytosource;
143 my ($binname, $binver, $binarch) = @_;
145 # TODO: This gets hit a lot, especially from buggyversion() - probably
146 # need an extra cache for speed here.
147 return () unless defined $gBinarySourceMap;
149 if (not tied %_binarytosource) {
150 tie %_binarytosource, MLDBM => $gBinarySourceMap, O_RDONLY or
151 die "Unable to open $gBinarySourceMap for reading";
154 # avoid autovivification
155 my $binary = $_binarytosource{$binname};
156 return () unless defined $binary;
157 my %binary = %{$binary};
158 if (not defined $binver) {
160 for my $ver (keys %binary) {
161 for my $ar (keys %{$binary{$ver}}) {
162 my $src = $binary{$ver}{$ar};
163 next unless defined $src;
164 $uniq{$src->[0]} = 1;
169 elsif (exists $binary{$binver}) {
170 if (defined $binarch) {
171 my $src = $binary{$binver}{$binarch};
172 return () unless defined $src; # not on this arch
173 # Copy the data to avoid tiedness problems.
176 # Get (srcname, srcver) pairs for all architectures and
177 # remove any duplicates. This involves some slightly tricky
178 # multidimensional hashing; sorry. Fortunately there'll
179 # usually only be one pair returned.
181 for my $ar (keys %{$binary{$binver}}) {
182 my $src = $binary{$binver}{$ar};
183 next unless defined $src;
184 $uniq{$src->[0]}{$src->[1]} = 1;
187 for my $sn (sort keys %uniq) {
188 push @uniq, [$sn, $_] for sort keys %{$uniq{$sn}};
194 # No $gBinarySourceMap, or it didn't have an entry for this name and
201 Returns a list of references to triplets of binary package names, versions,
202 and architectures corresponding to a given source package name and version.
203 If the given source package name and version cannot be found in the database
204 but the source package name is in the unversioned package-to-source map
205 file, then a reference to a binary package name and version pair will be
206 returned, without the architecture.
210 our %_sourcetobinary;
212 my ($srcname, $srcver) = @_;
214 if (not tied %_sourcetobinary) {
215 tie %_sourcetobinary, MLDBM => $gSourceBinaryMap, O_RDONLY or
216 die "Unable top open $gSourceBinaryMap for reading";
221 # avoid autovivification
222 my $source = $_sourcetobinary{$srcname};
223 return () unless defined $source;
224 my %source = %{$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 =item 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,
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);
450 my @packages = grep {defined $_ and length $_ } make_list($param{package});
451 my @archs = grep {defined $_ } make_list ($param{archs});
455 if (not exists $param{source_version_cache}) {
456 $param{source_version_cache} = \%_sourceversioncache;
458 if (grep {/,/} make_list($param{package})) {
459 croak "Package names contain ,; split on /,/ and call make_source_versions with an arrayref of packages"
462 for my $version (make_list($param{versions})) {
463 if ($version =~ m{(.+)/([^/]+)$}) {
464 # check to see if this source version is even possible
465 my @bin_versions = sourcetobinary($1,$2);
466 if (not @bin_versions or
467 @{$bin_versions[0]} != 3) {
468 print {$warnings} "The source $1 and version $2 do not appear to match any binary packages\n";
470 # Already a source version.
471 $sourceversions{$version} = 1;
474 croak "You must provide at least one package if the versions are not fully qualified";
476 for my $pkg (@packages) {
477 for my $arch (@archs) {
478 my $cachearch = (defined $arch) ? $arch : '';
479 my $cachekey = "$pkg/$cachearch/$version";
480 if (exists($param{source_version_cache}{$cachekey})) {
481 for my $v (@{$param{source_version_cache}{$cachekey}}) {
482 $sourceversions{$v} = 1;
486 my @srcinfo = binarytosource($pkg, $version, $arch);
488 # We don't have explicit information about the
489 # binary-to-source mapping for this version
491 print {$warnings} "There is no source info for the package '$pkg' at version '$version' with architecture '$arch'\n";
492 if ($param{guess_source}) {
494 my $pkgsrc = getpkgsrc();
495 if (exists $pkgsrc->{$pkg}) {
496 @srcinfo = ([$pkgsrc->{$pkg}, $version]);
497 } elsif (getsrcpkgs($pkg)) {
498 # If we're looking at a source package
499 # that doesn't have a binary of the
500 # same name, just try the same
502 @srcinfo = ([$pkg, $version]);
508 $sourceversions{"$_->[0]/$_->[1]"} = 1 foreach @srcinfo;
509 $param{source_version_cache}{$cachekey} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
514 return sort keys %sourceversions;