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(binary_to_source 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 sort_versions);
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 binary_to_source
126 binary_to_source(package => 'foo',
131 Turn a binary package (at optional version in optional architecture)
132 into a single (or set) of source packages (optionally) with associated
135 By default, in LIST context, returns a LIST of array refs of source
136 package, source version pairs corresponding to the binary package(s),
137 arch(s), and verion(s) passed.
139 In SCALAR context, only the corresponding source packages are
140 returned, concatenated with ', ' if necessary.
142 If no source can be found, returns undef in scalar context, or the
143 empty list in list context.
147 =item binary -- binary package name(s) as a SCALAR or ARRAYREF
149 =item version -- binary package version(s) as a SCALAR or ARRAYREF;
150 optional, defaults to all versions.
152 =item arch -- binary package architecture(s) as a SCALAR or ARRAYREF;
153 optional, defaults to all architectures.
155 =item source_only -- return only the source name (forced on if in
156 SCALAR context), defaults to false.
158 =item scalar_only -- return a scalar only (forced true if in SCALAR
159 context, also causes source_only to be true), defaults to false.
161 =item cache -- optional HASHREF to be used to cache results of
168 # the two global variables below are used to tie the source maps; we
169 # probably should be retying them in long lived processes.
170 our %_binarytosource;
171 our %_sourcetobinary;
172 sub binary_to_source{
173 my %param = validate_with(params => \@_,
174 spec => {binary => {type => SCALAR|ARRAYREF,
176 version => {type => SCALAR|ARRAYREF,
179 arch => {type => SCALAR|ARRAYREF,
182 source_only => {default => 0,
184 scalar_only => {default => 0,
186 cache => {type => HASHREF,
192 # TODO: This gets hit a lot, especially from buggyversion() - probably
193 # need an extra cache for speed here.
194 return () unless defined $gBinarySourceMap;
196 if ($param{scalar_only} or not wantarray) {
197 $param{source_only} = 1;
198 $param{scalar_only} = 1;
202 my @binaries = grep {defined $_} make_list(exists $param{binary}?$param{binary}:[]);
203 my @versions = grep {defined $_} make_list(exists $param{version}?$param{version}:[]);
204 my @archs = grep {defined $_} make_list(exists $param{arch}?$param{arch}:[]);
205 return () unless @binaries;
206 my $cache_key = join("\1",
207 join("\0",@binaries),
208 join("\0",@versions),
210 join("\0",@param{qw(source_only scalar_only)}));
211 if (exists $param{cache}{$cache_key}) {
212 return $param{scalar_only} ? $param{cache}{$cache_key}[0]:
213 @{$param{cache}{$cache_key}};
215 for my $binary (@binaries) {
216 if ($binary =~ m/^src:(.+)$/) {
217 push @source,[$1,''];
220 if (not tied %_binarytosource) {
221 tie %_binarytosource, MLDBM => $config{binary_source_map}, O_RDONLY or
222 die "Unable to open $config{binary_source_map} for reading";
224 # avoid autovivification
225 my $bin = $_binarytosource{$binary};
226 next unless defined $bin;
228 for my $ver (keys %{$bin}) {
229 for my $ar (keys %{$bin->{$ver}}) {
230 my $src = $bin->{$ver}{$ar};
231 next unless defined $src;
232 push @source,[$src->[0],$src->[1]];
237 my $found_one_version = 0;
238 for my $version (@versions) {
239 next unless exists $bin->{$version};
240 if (exists $bin->{$version}{all}) {
241 push @source,dclone($bin->{$version}{all});
249 @t_archs = keys %{$bin->{$version}};
251 for my $arch (@t_archs) {
252 push @source,dclone($bin->{$version}{$arch}) if
253 exists $bin->{$version}{$arch};
259 if (not @source and not @versions and not @archs) {
260 # ok, we haven't found any results at all. If we weren't given
261 # a specific version and architecture, then we should try
262 # really hard to figure out the right source
264 # if any the packages we've been given are a valid source
265 # package name, and there's no binary of the same name (we got
266 # here, so there isn't), return it.
268 if (not tied %_sourcetobinary) {
269 tie %_sourcetobinary, MLDBM => $config{source_binary_map}, O_RDONLY or
270 die "Unable top open $gSourceBinaryMap for reading";
272 for my $maybe_sourcepkg (@binaries) {
273 if (exists $_sourcetobinary{$maybe_sourcepkg}) {
274 push @source,[$maybe_sourcepkg,$_] for keys %{$_sourcetobinary{$maybe_sourcepkg}};
277 # if @source is still empty here, it's probably a non-existant
278 # source package, so don't return anything.
283 if ($param{source_only}) {
285 for my $s (@source) {
286 # we shouldn't need to do this, but do this temporarily to
288 next unless defined $s->[0];
291 @result = sort keys %uniq;
292 if ($param{scalar_only}) {
293 @result = join(', ',@result);
298 for my $s (@source) {
299 $uniq{$s->[0]}{$s->[1]} = 1;
301 for my $sn (sort keys %uniq) {
302 push @result, [$sn, $_] for sort keys %{$uniq{$sn}};
306 # No $gBinarySourceMap, or it didn't have an entry for this name and
308 $param{cache}{$cache_key} = \@result;
309 return $param{scalar_only} ? $result[0] : @result;
312 =head2 sourcetobinary
314 Returns a list of references to triplets of binary package names, versions,
315 and architectures corresponding to a given source package name and version.
316 If the given source package name and version cannot be found in the database
317 but the source package name is in the unversioned package-to-source map
318 file, then a reference to a binary package name and version pair will be
319 returned, without the architecture.
324 my ($srcname, $srcver) = @_;
326 if (not tied %_sourcetobinary) {
327 tie %_sourcetobinary, MLDBM => $config{source_binary_map}, O_RDONLY or
328 die "Unable top open $config{source_binary_map} for reading";
333 # avoid autovivification
334 my $source = $_sourcetobinary{$srcname};
335 return () unless defined $source;
336 if (exists $source->{$srcver}) {
337 my $bin = $source->{$srcver};
338 return () unless defined $bin;
341 # No $gSourceBinaryMap, or it didn't have an entry for this name and
342 # version. Try $gPackageSource (unversioned) instead.
343 my @srcpkgs = getsrcpkgs($srcname);
344 return map [$_, $srcver], @srcpkgs;
349 Returns versions of the package in a distribution at a specific
355 my ($pkg, $dist, $arch) = @_;
356 return get_versions(package=>$pkg,
358 defined $arch ? (arch => $arch):(),
366 get_versions(package=>'foopkg',
371 Returns a list of the versions of package in the distributions and
372 architectures listed. This routine only returns unique values.
376 =item package -- package to return list of versions
378 =item dist -- distribution (unstable, stable, testing); can be an
381 =item arch -- architecture (i386, source, ...); can be an arrayref
383 =item time -- returns a version=>time hash at which the newest package
384 matching this version was uploaded
386 =item source -- returns source/version instead of just versions
388 =item no_source_arch -- discards the source architecture when arch is
389 not passed. [Used for finding the versions of binary packages only.]
390 Defaults to 0, which does not discard the source architecture. (This
391 may change in the future, so if you care, please code accordingly.)
393 =item return_archs -- returns a version=>[archs] hash indicating which
394 architectures are at which versions.
396 =item largest_source_version_only -- if there is more than one source
397 version in a particular distribution, discards all versions but the
398 largest in that distribution. Defaults to 1, as this used to be the
399 way that the Debian archive worked.
403 When called in scalar context, this function will return hashrefs or
404 arrayrefs as appropriate, in list context, it will return paired lists
405 or unpaired lists as appropriate.
413 my %param = validate_with(params => \@_,
414 spec => {package => {type => SCALAR|ARRAYREF,
416 dist => {type => SCALAR|ARRAYREF,
417 default => 'unstable',
419 arch => {type => SCALAR|ARRAYREF,
422 time => {type => BOOLEAN,
425 source => {type => BOOLEAN,
428 no_source_arch => {type => BOOLEAN,
431 return_archs => {type => BOOLEAN,
434 largest_source_version_only => {type => BOOLEAN,
441 return () if not defined $gVersionTimeIndex;
442 unless (tied %_versions_time) {
443 tie %_versions_time, 'MLDBM', $gVersionTimeIndex, O_RDONLY
444 or die "can't open versions index $gVersionTimeIndex: $!";
446 $versions = \%_versions_time;
449 return () if not defined $gVersionIndex;
450 unless (tied %_versions) {
451 tie %_versions, 'MLDBM', $gVersionIndex, O_RDONLY
452 or die "can't open versions index $gVersionIndex: $!";
454 $versions = \%_versions;
457 for my $package (make_list($param{package})) {
459 if ($package =~ s/^src://) {
462 my $version = $versions->{$package};
463 next unless defined $version;
464 for my $dist (make_list($param{dist})) {
465 for my $arch (exists $param{arch}?
466 make_list($param{arch}):
467 (grep {not $param{no_source_arch} or
469 } $source_only?'source':keys %{$version->{$dist}})) {
470 next unless defined $version->{$dist}{$arch};
471 my @vers = ref $version->{$dist}{$arch} eq 'HASH' ?
472 keys %{$version->{$dist}{$arch}} :
473 make_list($version->{$dist}{$arch});
474 if ($param{largest_source_version_only} and
475 $arch eq 'source' and @vers > 1) {
476 # order the versions, then pick the biggest version number
477 @vers = sort_versions(@vers);
480 for my $ver (@vers) {
482 if ($param{source}) {
483 ($f_ver) = make_source_versions(package => $package,
486 next unless defined $f_ver;
489 $versions{$f_ver} = max($versions{$f_ver}||0,$version->{$dist}{$arch}{$ver});
492 push @{$versions{$f_ver}},$arch;
498 if ($param{time} or $param{return_archs}) {
499 return wantarray?%versions :\%versions;
501 return wantarray?keys %versions :[keys %versions];
505 =head2 makesourceversions
507 @{$cgi_var{found}} = makesourceversions($cgi_var{package},undef,@{$cgi_var{found}});
509 Canonicalize versions into source versions, which have an explicitly
510 named source package. This is used to cope with source packages whose
511 names have changed during their history, and with cases where source
512 version numbers differ from binary version numbers.
516 our %_sourceversioncache = ();
517 sub makesourceversions {
518 my ($package,$arch,@versions) = @_;
519 die "Package $package is multiple packages; split on , and call makesourceversions multiple times"
521 return make_source_versions(package => $package,
522 (defined $arch)?(arch => $arch):(),
523 versions => \@versions
527 =head2 make_source_versions
529 make_source_versions(package => 'foo',
534 warnings => \$warnings,
537 An extended version of makesourceversions (which calls this function
538 internally) that allows for multiple packages, architectures, and
539 outputs warnings and debugging information to provided SCALARREFs or
542 The guess_source option determines whether the source package is
543 guessed at if there is no obviously correct package. Things that use
544 this function for non-transient output should set this to false,
545 things that use it for transient output can set this to true.
546 Currently it defaults to true, but that is not a sane option.
551 sub make_source_versions {
552 my %param = validate_with(params => \@_,
553 spec => {package => {type => SCALAR|ARRAYREF,
555 arch => {type => SCALAR|ARRAYREF|UNDEF,
558 versions => {type => SCALAR|ARRAYREF,
561 guess_source => {type => BOOLEAN,
564 source_version_cache => {type => HASHREF,
567 debug => {type => SCALARREF|HANDLE,
570 warnings => {type => SCALARREF|HANDLE,
575 my ($warnings) = globify_scalar(exists $param{warnings}?$param{warnings}:undef);
576 my ($debug) = globify_scalar(exists $param{debug} ?$param{debug} :undef);
578 my @packages = grep {defined $_ and length $_ } make_list($param{package});
579 my @archs = grep {defined $_ } make_list ($param{arch});
583 if (not exists $param{source_version_cache}) {
584 $param{source_version_cache} = \%_sourceversioncache;
586 if (grep {/,/} make_list($param{package})) {
587 croak "Package names contain ,; split on /,/ and call make_source_versions with an arrayref of packages"
590 for my $version (make_list($param{versions})) {
591 if ($version =~ m{(.+)/([^/]+)$}) {
592 # Already a source version.
593 $sourceversions{$version} = 1;
594 next unless exists $param{warnings};
595 # check to see if this source version is even possible
596 my @bin_versions = sourcetobinary($1,$2);
597 if (not @bin_versions or
598 @{$bin_versions[0]} != 3) {
599 print {$warnings} "The source $1 and version $2 do not appear to match any binary packages\n";
603 croak "You must provide at least one package if the versions are not fully qualified";
605 for my $pkg (@packages) {
606 if ($pkg =~ /^src:(.+)/) {
607 $sourceversions{"$1/$version"} = 1;
608 next unless exists $param{warnings};
609 # check to see if this source version is even possible
610 my @bin_versions = sourcetobinary($1,$version);
611 if (not @bin_versions or
612 @{$bin_versions[0]} != 3) {
613 print {$warnings} "The source '$1' and version '$version' do not appear to match any binary packages\n";
617 for my $arch (@archs) {
618 my $cachearch = (defined $arch) ? $arch : '';
619 my $cachekey = "$pkg/$cachearch/$version";
620 if (exists($param{source_version_cache}{$cachekey})) {
621 for my $v (@{$param{source_version_cache}{$cachekey}}) {
622 $sourceversions{$v} = 1;
626 elsif ($param{guess_source} and
627 exists$param{source_version_cache}{$cachekey.'/guess'}) {
628 for my $v (@{$param{source_version_cache}{$cachekey.'/guess'}}) {
629 $sourceversions{$v} = 1;
633 my @srcinfo = binary_to_source(binary => $pkg,
635 length($arch)?(arch => $arch):());
637 # We don't have explicit information about the
638 # binary-to-source mapping for this version
640 print {$warnings} "There is no source info for the package '$pkg' at version '$version' with architecture '$arch'\n";
641 if ($param{guess_source}) {
643 my $pkgsrc = getpkgsrc();
644 if (exists $pkgsrc->{$pkg}) {
645 @srcinfo = ([$pkgsrc->{$pkg}, $version]);
646 } elsif (getsrcpkgs($pkg)) {
647 # If we're looking at a source package
648 # that doesn't have a binary of the
649 # same name, just try the same
651 @srcinfo = ([$pkg, $version]);
655 # store guesses in a slightly different location
656 $param{source_version_cache}{$cachekey.'/guess'} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
660 # only store this if we didn't have to guess it
661 $param{source_version_cache}{$cachekey} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
663 $sourceversions{"$_->[0]/$_->[1]"} = 1 foreach @srcinfo;
668 return sort keys %sourceversions;