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);
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.
144 =item binary -- binary package name(s) as a SCALAR or ARRAYREF
146 =item version -- binary package version(s) as a SCALAR or ARRAYREF;
147 optional, defaults to all versions.
149 =item arch -- binary package architecture(s) as a SCALAR or ARRAYREF;
150 optional, defaults to all architectures.
152 =item source_only -- return only the source name (forced on if in
153 SCALAR context), defaults to false.
155 =item scalar_only -- return a scalar only (forced true if in SCALAR
156 context, also causes source_only to be true), defaults to false.
158 =item cache -- optional HASHREF to be used to cache results of
165 # the two global variables below are used to tie the source maps; we
166 # probably should be retying them in long lived processes.
167 our %_binarytosource;
168 our %_sourcetobinary;
169 sub binary_to_source{
170 my %param = validate_with(params => \@_,
171 spec => {binary => {type => SCALAR|ARRAYREF,
173 version => {type => SCALAR|ARRAYREF,
176 arch => {type => SCALAR|ARRAYREF,
179 source_only => {default => 0,
181 scalar_only => {default => 0,
183 cache => {type => HASHREF,
189 # TODO: This gets hit a lot, especially from buggyversion() - probably
190 # need an extra cache for speed here.
191 return () unless defined $gBinarySourceMap;
193 if ($param{scalar_only} or not wantarray) {
194 $param{source_only} = 1;
195 $param{scalar_only} = 1;
199 my @binaries = grep {defined $_} make_list(exists $param{binary}?$param{binary}:[]);
200 my @versions = grep {defined $_} make_list(exists $param{version}?$param{version}:[]);
201 my @archs = grep {defined $_} make_list(exists $param{arch}?$param{arch}:[]);
202 return () unless @binaries;
203 my $cache_key = join("\1",
204 join("\0",@binaries),
205 join("\0",@versions),
207 join("\0",@param{qw(source_only scalar_only)}));
208 if (exists $param{cache}{$cache_key}) {
209 return $param{scalar_only} ? $param{cache}{$cache_key}[0]:
210 @{$param{cache}{$cache_key}};
212 for my $binary (@binaries) {
213 if ($binary =~ m/^src:(.+)$/) {
214 push @source,[$1,''];
217 if (not tied %_binarytosource) {
218 tie %_binarytosource, MLDBM => $config{binary_source_map}, O_RDONLY or
219 die "Unable to open $config{binary_source_map} for reading";
221 # avoid autovivification
222 my $bin = $_binarytosource{$binary};
224 next unless defined $bin;
225 for my $ver (keys %{$bin}) {
226 for my $ar (keys %{$bin->{$ver}}) {
227 my $src = $bin->{$ver}{$ar};
228 next unless defined $src;
229 push @source,[$src->[0],$src->[1]];
234 my $found_one_version = 0;
235 for my $version (@versions) {
236 next unless exists $bin->{$version};
237 if (exists $bin->{$version}{all}) {
238 push @source,dclone($bin->{$version}{all});
246 @t_archs = keys %{$bin->{$version}};
248 for my $arch (@t_archs) {
249 push @source,dclone($bin->{$version}{$arch}) if
250 exists $bin->{$version}{$arch};
256 if (not @source and not @versions and not @archs) {
257 # ok, we haven't found any results at all. If we weren't given
258 # a specific version and architecture, then we should try
259 # really hard to figure out the right source
261 # if any the packages we've been given are a valid source
262 # package name, and there's no binary of the same name (we got
263 # here, so there isn't), return it.
265 if (not tied %_sourcetobinary) {
266 tie %_sourcetobinary, MLDBM => $config{source_binary_map}, O_RDONLY or
267 die "Unable top open $gSourceBinaryMap for reading";
269 for my $package (@package) {
270 if (exists $_sourcetobinary{$package}) {
271 push @source,[$package,$_] for keys %{$_sourcetobinary{$package}};
274 # if @source is still empty here, it's probably a non-existant
275 # source package, so don't return anything.
280 if ($param{source_only}) {
282 for my $s (@source) {
285 @result = sort keys %uniq;
286 if ($param{scalar_only}) {
287 @result = join(', ',@result);
292 for my $s (@source) {
293 $uniq{$s->[0]}{$s->[1]} = 1;
295 for my $sn (sort keys %uniq) {
296 push @result, [$sn, $_] for sort keys %{$uniq{$sn}};
300 # No $gBinarySourceMap, or it didn't have an entry for this name and
302 $param{cache}{$cache_key} = \@result;
303 return $param{scalar_only} ? $result[0] : @result;
306 =head2 sourcetobinary
308 Returns a list of references to triplets of binary package names, versions,
309 and architectures corresponding to a given source package name and version.
310 If the given source package name and version cannot be found in the database
311 but the source package name is in the unversioned package-to-source map
312 file, then a reference to a binary package name and version pair will be
313 returned, without the architecture.
318 my ($srcname, $srcver) = @_;
320 if (not tied %_sourcetobinary) {
321 tie %_sourcetobinary, MLDBM => $config{source_binary_map}, O_RDONLY or
322 die "Unable top open $config{source_binary_map} for reading";
327 # avoid autovivification
328 my $source = $_sourcetobinary{$srcname};
329 return () unless defined $source;
330 if (exists $source->{$srcver}) {
331 my $bin = $source->{$srcver};
332 return () unless defined $bin;
335 # No $gSourceBinaryMap, or it didn't have an entry for this name and
336 # version. Try $gPackageSource (unversioned) instead.
337 my @srcpkgs = getsrcpkgs($srcname);
338 return map [$_, $srcver], @srcpkgs;
343 Returns versions of the package in a distribution at a specific
349 my ($pkg, $dist, $arch) = @_;
350 return get_versions(package=>$pkg,
352 defined $arch ? (arch => $arch):(),
360 get_versions(package=>'foopkg',
365 Returns a list of the versions of package in the distributions and
366 architectures listed. This routine only returns unique values.
370 =item package -- package to return list of versions
372 =item dist -- distribution (unstable, stable, testing); can be an
375 =item arch -- architecture (i386, source, ...); can be an arrayref
377 =item time -- returns a version=>time hash at which the newest package
378 matching this version was uploaded
380 =item source -- returns source/version instead of just versions
382 =item no_source_arch -- discards the source architecture when arch is
383 not passed. [Used for finding the versions of binary packages only.]
384 Defaults to 0, which does not discard the source architecture. (This
385 may change in the future, so if you care, please code accordingly.)
387 =item return_archs -- returns a version=>[archs] hash indicating which
388 architectures are at which versions.
392 When called in scalar context, this function will return hashrefs or
393 arrayrefs as appropriate, in list context, it will return paired lists
394 or unpaired lists as appropriate.
402 my %param = validate_with(params => \@_,
403 spec => {package => {type => SCALAR|ARRAYREF,
405 dist => {type => SCALAR|ARRAYREF,
406 default => 'unstable',
408 arch => {type => SCALAR|ARRAYREF,
411 time => {type => BOOLEAN,
414 source => {type => BOOLEAN,
417 no_source_arch => {type => BOOLEAN,
420 return_archs => {type => BOOLEAN,
427 return () if not defined $gVersionTimeIndex;
428 unless (tied %_versions_time) {
429 tie %_versions_time, 'MLDBM', $gVersionTimeIndex, O_RDONLY
430 or die "can't open versions index $gVersionTimeIndex: $!";
432 $versions = \%_versions_time;
435 return () if not defined $gVersionIndex;
436 unless (tied %_versions) {
437 tie %_versions, 'MLDBM', $gVersionIndex, O_RDONLY
438 or die "can't open versions index $gVersionIndex: $!";
440 $versions = \%_versions;
443 for my $package (make_list($param{package})) {
444 my $version = $versions->{$package};
445 next unless defined $version;
446 for my $dist (make_list($param{dist})) {
447 for my $arch (exists $param{arch}?
448 make_list($param{arch}):
449 (grep {not $param{no_source_arch} or
451 } keys %{$version->{$dist}})) {
452 next unless defined $version->{$dist}{$arch};
453 for my $ver (ref $version->{$dist}{$arch} ?
454 keys %{$version->{$dist}{$arch}} :
455 $version->{$dist}{$arch}
458 if ($param{source}) {
459 ($f_ver) = make_source_versions(package => $package,
462 next unless defined $f_ver;
465 $versions{$f_ver} = max($versions{$f_ver}||0,$version->{$dist}{$arch}{$ver});
468 push @{$versions{$f_ver}},$arch;
474 if ($param{time} or $param{return_archs}) {
475 return wantarray?%versions :\%versions;
477 return wantarray?keys %versions :[keys %versions];
481 =head2 makesourceversions
483 @{$cgi_var{found}} = makesourceversions($cgi_var{package},undef,@{$cgi_var{found}});
485 Canonicalize versions into source versions, which have an explicitly
486 named source package. This is used to cope with source packages whose
487 names have changed during their history, and with cases where source
488 version numbers differ from binary version numbers.
492 our %_sourceversioncache = ();
493 sub makesourceversions {
494 my ($package,$arch,@versions) = @_;
495 die "Package $package is multiple packages; split on , and call makesourceversions multiple times"
497 return make_source_versions(package => $package,
498 (defined $arch)?(arch => $arch):(),
499 versions => \@versions
503 =head2 make_source_versions
505 make_source_versions(package => 'foo',
510 warnings => \$warnings,
513 An extended version of makesourceversions (which calls this function
514 internally) that allows for multiple packages, architectures, and
515 outputs warnings and debugging information to provided SCALARREFs or
518 The guess_source option determines whether the source package is
519 guessed at if there is no obviously correct package. Things that use
520 this function for non-transient output should set this to false,
521 things that use it for transient output can set this to true.
522 Currently it defaults to true, but that is not a sane option.
527 sub make_source_versions {
528 my %param = validate_with(params => \@_,
529 spec => {package => {type => SCALAR|ARRAYREF,
531 arch => {type => SCALAR|ARRAYREF|UNDEF,
534 versions => {type => SCALAR|ARRAYREF,
537 guess_source => {type => BOOLEAN,
540 source_version_cache => {type => HASHREF,
543 debug => {type => SCALARREF|HANDLE,
546 warnings => {type => SCALARREF|HANDLE,
551 my ($warnings) = globify_scalar(exists $param{warnings}?$param{warnings}:undef);
552 my ($debug) = globify_scalar(exists $param{debug} ?$param{debug} :undef);
554 my @packages = grep {defined $_ and length $_ } make_list($param{package});
555 my @archs = grep {defined $_ } make_list ($param{arch});
559 if (not exists $param{source_version_cache}) {
560 $param{source_version_cache} = \%_sourceversioncache;
562 if (grep {/,/} make_list($param{package})) {
563 croak "Package names contain ,; split on /,/ and call make_source_versions with an arrayref of packages"
566 for my $version (make_list($param{versions})) {
567 if ($version =~ m{(.+)/([^/]+)$}) {
568 # Already a source version.
569 $sourceversions{$version} = 1;
570 next unless exists $param{warnings};
571 # check to see if this source version is even possible
572 my @bin_versions = sourcetobinary($1,$2);
573 if (not @bin_versions or
574 @{$bin_versions[0]} != 3) {
575 print {$warnings} "The source $1 and version $2 do not appear to match any binary packages\n";
579 croak "You must provide at least one package if the versions are not fully qualified";
581 for my $pkg (@packages) {
582 if ($pkg =~ /^src:(.+)/) {
583 $sourceversions{"$1/$version"} = 1;
584 next unless exists $param{warnings};
585 # check to see if this source version is even possible
586 my @bin_versions = sourcetobinary($1,$version);
587 if (not @bin_versions or
588 @{$bin_versions[0]} != 3) {
589 print {$warnings} "The source $1 and version $2 do not appear to match any binary packages\n";
593 for my $arch (@archs) {
594 my $cachearch = (defined $arch) ? $arch : '';
595 my $cachekey = "$pkg/$cachearch/$version";
596 if (exists($param{source_version_cache}{$cachekey})) {
597 for my $v (@{$param{source_version_cache}{$cachekey}}) {
598 $sourceversions{$v} = 1;
602 elsif ($param{guess_source} and
603 exists$param{source_version_cache}{$cachekey.'/guess'}) {
604 for my $v (@{$param{source_version_cache}{$cachekey.'/guess'}}) {
605 $sourceversions{$v} = 1;
609 my @srcinfo = binary_to_source(binary => $pkg,
613 # We don't have explicit information about the
614 # binary-to-source mapping for this version
616 print {$warnings} "There is no source info for the package '$pkg' at version '$version' with architecture '$arch'\n";
617 if ($param{guess_source}) {
619 my $pkgsrc = getpkgsrc();
620 if (exists $pkgsrc->{$pkg}) {
621 @srcinfo = ([$pkgsrc->{$pkg}, $version]);
622 } elsif (getsrcpkgs($pkg)) {
623 # If we're looking at a source package
624 # that doesn't have a binary of the
625 # same name, just try the same
627 @srcinfo = ([$pkg, $version]);
631 # store guesses in a slightly different location
632 $param{source_version_cache}{$cachekey.'/guess'} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
636 # only store this if we didn't have to guess it
637 $param{source_version_cache}{$cachekey} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
639 $sourceversions{"$_->[0]/$_->[1]"} = 1 foreach @srcinfo;
644 return sort keys %sourceversions;