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 Exporter qw(import);
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::AllUtils 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 $config{package_source} and
76 length $config{package_source};
81 my $fh = IO::File->new($config{package_source},'r')
82 or die("Unable to open $config{package_source} for reading: $!");
84 next unless m/^(\S+)\s+(\S+)\s+(\S.*\S)\s*$/;
85 my ($bin,$cmp,$src)=($1,$2,$3);
88 push @{$srcpkg{$src}}, $bin;
89 $pkgcomponent{$bin}= $cmp;
93 $_pkgcomponent = \%pkgcomponent;
98 =head2 getpkgcomponent
100 Returns a reference to a hash of binary package names to the component of
101 the archive containing those binary packages (e.g. "main", "contrib",
106 sub getpkgcomponent {
107 return $_pkgcomponent if $_pkgcomponent;
109 return $_pkgcomponent;
114 Returns a list of the binary packages produced by a given source package.
120 getpkgsrc() if not defined $_srcpkg;
121 return () if not defined $src or not exists $_srcpkg->{$src};
122 return @{$_srcpkg->{$src}};
125 =head2 binary_to_source
127 binary_to_source(package => 'foo',
132 Turn a binary package (at optional version in optional architecture)
133 into a single (or set) of source packages (optionally) with associated
136 By default, in LIST context, returns a LIST of array refs of source
137 package, source version pairs corresponding to the binary package(s),
138 arch(s), and verion(s) passed.
140 In SCALAR context, only the corresponding source packages are
141 returned, concatenated with ', ' if necessary.
143 If no source can be found, returns undef in scalar context, or the
144 empty list in list context.
148 =item binary -- binary package name(s) as a SCALAR or ARRAYREF
150 =item version -- binary package version(s) as a SCALAR or ARRAYREF;
151 optional, defaults to all versions.
153 =item arch -- binary package architecture(s) as a SCALAR or ARRAYREF;
154 optional, defaults to all architectures.
156 =item source_only -- return only the source name (forced on if in
157 SCALAR context), defaults to false.
159 =item scalar_only -- return a scalar only (forced true if in SCALAR
160 context, also causes source_only to be true), defaults to false.
162 =item cache -- optional HASHREF to be used to cache results of
169 # the two global variables below are used to tie the source maps; we
170 # probably should be retying them in long lived processes.
171 our %_binarytosource;
172 our %_sourcetobinary;
173 sub binary_to_source{
174 my %param = validate_with(params => \@_,
175 spec => {binary => {type => SCALAR|ARRAYREF,
177 version => {type => SCALAR|ARRAYREF,
180 arch => {type => SCALAR|ARRAYREF,
183 source_only => {default => 0,
185 scalar_only => {default => 0,
187 cache => {type => HASHREF,
193 # TODO: This gets hit a lot, especially from buggyversion() - probably
194 # need an extra cache for speed here.
195 return () unless defined $gBinarySourceMap;
197 if ($param{scalar_only} or not wantarray) {
198 $param{source_only} = 1;
199 $param{scalar_only} = 1;
203 my @binaries = grep {defined $_} make_list(exists $param{binary}?$param{binary}:[]);
204 my @versions = grep {defined $_} make_list(exists $param{version}?$param{version}:[]);
205 my @archs = grep {defined $_} make_list(exists $param{arch}?$param{arch}:[]);
206 return () unless @binaries;
207 my $cache_key = join("\1",
208 join("\0",@binaries),
209 join("\0",@versions),
211 join("\0",@param{qw(source_only scalar_only)}));
212 if (exists $param{cache}{$cache_key}) {
213 return $param{scalar_only} ? $param{cache}{$cache_key}[0]:
214 @{$param{cache}{$cache_key}};
216 for my $binary (@binaries) {
217 if ($binary =~ m/^src:(.+)$/) {
218 push @source,[$1,''];
221 if (not tied %_binarytosource) {
222 tie %_binarytosource, MLDBM => $config{binary_source_map}, O_RDONLY or
223 die "Unable to open $config{binary_source_map} for reading";
225 # avoid autovivification
226 my $bin = $_binarytosource{$binary};
227 next unless defined $bin;
229 for my $ver (keys %{$bin}) {
230 for my $ar (keys %{$bin->{$ver}}) {
231 my $src = $bin->{$ver}{$ar};
232 next unless defined $src;
233 push @source,[$src->[0],$src->[1]];
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',
533 warnings => \$warnings,
536 An extended version of makesourceversions (which calls this function
537 internally) that allows for multiple packages, architectures, and
538 outputs warnings and debugging information to provided SCALARREFs or
541 The guess_source option determines whether the source package is
542 guessed at if there is no obviously correct package. Things that use
543 this function for non-transient output should set this to false,
544 things that use it for transient output can set this to true.
545 Currently it defaults to true, but that is not a sane option.
550 sub make_source_versions {
551 my %param = validate_with(params => \@_,
552 spec => {package => {type => SCALAR|ARRAYREF,
554 arch => {type => SCALAR|ARRAYREF|UNDEF,
557 versions => {type => SCALAR|ARRAYREF,
560 guess_source => {type => BOOLEAN,
563 source_version_cache => {type => HASHREF,
566 debug => {type => SCALARREF|HANDLE,
569 warnings => {type => SCALARREF|HANDLE,
574 my ($warnings) = globify_scalar(exists $param{warnings}?$param{warnings}:undef);
576 my @packages = grep {defined $_ and length $_ } make_list($param{package});
577 my @archs = grep {defined $_ } make_list ($param{arch});
581 if (not exists $param{source_version_cache}) {
582 $param{source_version_cache} = \%_sourceversioncache;
584 if (grep {/,/} make_list($param{package})) {
585 croak "Package names contain ,; split on /,/ and call make_source_versions with an arrayref of packages"
588 for my $version (make_list($param{versions})) {
589 if ($version =~ m{(.+)/([^/]+)$}) {
590 # Already a source version.
591 $sourceversions{$version} = 1;
592 next unless exists $param{warnings};
593 # check to see if this source version is even possible
594 my @bin_versions = sourcetobinary($1,$2);
595 if (not @bin_versions or
596 @{$bin_versions[0]} != 3) {
597 print {$warnings} "The source $1 and version $2 do not appear to match any binary packages\n";
601 croak "You must provide at least one package if the versions are not fully qualified";
603 for my $pkg (@packages) {
604 if ($pkg =~ /^src:(.+)/) {
605 $sourceversions{"$1/$version"} = 1;
606 next unless exists $param{warnings};
607 # check to see if this source version is even possible
608 my @bin_versions = sourcetobinary($1,$version);
609 if (not @bin_versions or
610 @{$bin_versions[0]} != 3) {
611 print {$warnings} "The source '$1' and version '$version' do not appear to match any binary packages\n";
615 for my $arch (@archs) {
616 my $cachearch = (defined $arch) ? $arch : '';
617 my $cachekey = "$pkg/$cachearch/$version";
618 if (exists($param{source_version_cache}{$cachekey})) {
619 for my $v (@{$param{source_version_cache}{$cachekey}}) {
620 $sourceversions{$v} = 1;
624 elsif ($param{guess_source} and
625 exists$param{source_version_cache}{$cachekey.'/guess'}) {
626 for my $v (@{$param{source_version_cache}{$cachekey.'/guess'}}) {
627 $sourceversions{$v} = 1;
631 my @srcinfo = binary_to_source(binary => $pkg,
633 length($arch)?(arch => $arch):());
635 # We don't have explicit information about the
636 # binary-to-source mapping for this version
638 print {$warnings} "There is no source info for the package '$pkg' at version '$version' with architecture '$arch'\n";
639 if ($param{guess_source}) {
641 my $pkgsrc = getpkgsrc();
642 if (exists $pkgsrc->{$pkg}) {
643 @srcinfo = ([$pkgsrc->{$pkg}, $version]);
644 } elsif (getsrcpkgs($pkg)) {
645 # If we're looking at a source package
646 # that doesn't have a binary of the
647 # same name, just try the same
649 @srcinfo = ([$pkg, $version]);
653 # store guesses in a slightly different location
654 $param{source_version_cache}{$cachekey.'/guess'} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
658 # only store this if we didn't have to guess it
659 $param{source_version_cache}{$cachekey} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
661 $sourceversions{"$_->[0]/$_->[1]"} = 1 foreach @srcinfo;
666 return sort keys %sourceversions;