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::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,
189 schema => {type => OBJECT,
195 # TODO: This gets hit a lot, especially from buggyversion() - probably
196 # need an extra cache for speed here.
197 return () unless defined $gBinarySourceMap or defined $param{schema};
199 if ($param{scalar_only} or not wantarray) {
200 $param{source_only} = 1;
201 $param{scalar_only} = 1;
205 my @binaries = grep {defined $_} make_list(exists $param{binary}?$param{binary}:[]);
206 my @versions = grep {defined $_} make_list(exists $param{version}?$param{version}:[]);
207 my @archs = grep {defined $_} make_list(exists $param{arch}?$param{arch}:[]);
208 return () unless @binaries;
210 # any src:foo is source package foo with unspecified version
211 @source = map {/^src:(.+)$/?
212 [$1,'']:()} @binaries;
213 @binaries = grep {$_ !~ /^src:/} @binaries;
214 if ($param{schema}) {
215 if ($param{source_only}) {
216 @source = map {$_->[0]} @source;
217 my $src_rs = $param{schema}->resultset('SrcPkg')->
218 search_rs({'binpkg.pkg' => [@binaries],
219 @versions?('bin_vers.ver' => [@versions]):(),
220 @archs?('arch.arch' => [@archs]):(),
222 {join => {'src_vers'=>
223 {'bin_vers'=> ['arch','bin_pkg']}
229 map {$_->pkg} $src_rs->all;
230 if ($param{scalar_only}) {
231 return join(',',@source);
236 my $src_rs = $param{schema}->resultset('SrcVer')->
237 search_rs({'bin_pkg.pkg' => [@binaries],
238 @versions?('bin_vers.ver' => [@versions]):(),
239 @archs?('arch.arch' => [@archs]):(),
242 {'bin_vers' => ['arch','binpkg']},
248 map {[$_->get_column('src_pkg.pkg'),
249 $_->get_column('src_ver.ver'),
251 if (not @source and not @versions and not @archs) {
252 $src_rs = $param{schema}->resultset('SrcPkg')->
253 search_rs({pkg => [@binaries]},
262 my $cache_key = join("\1",
263 join("\0",@binaries),
264 join("\0",@versions),
266 join("\0",@param{qw(source_only scalar_only)}));
267 if (exists $param{cache}{$cache_key}) {
268 return $param{scalar_only} ? $param{cache}{$cache_key}[0]:
269 @{$param{cache}{$cache_key}};
271 for my $binary (@binaries) {
272 if (not tied %_binarytosource) {
273 tie %_binarytosource, MLDBM => $config{binary_source_map}, O_RDONLY or
274 die "Unable to open $config{binary_source_map} for reading";
276 # avoid autovivification
277 my $bin = $_binarytosource{$binary};
278 next unless defined $bin;
280 for my $ver (keys %{$bin}) {
281 for my $ar (keys %{$bin->{$ver}}) {
282 my $src = $bin->{$ver}{$ar};
283 next unless defined $src;
284 push @source,[$src->[0],$src->[1]];
289 my $found_one_version = 0;
290 for my $version (@versions) {
291 next unless exists $bin->{$version};
292 if (exists $bin->{$version}{all}) {
293 push @source,dclone($bin->{$version}{all});
301 @t_archs = keys %{$bin->{$version}};
303 for my $arch (@t_archs) {
304 push @source,dclone($bin->{$version}{$arch}) if
305 exists $bin->{$version}{$arch};
311 if (not @source and not @versions and not @archs) {
312 # ok, we haven't found any results at all. If we weren't given
313 # a specific version and architecture, then we should try
314 # really hard to figure out the right source
316 # if any the packages we've been given are a valid source
317 # package name, and there's no binary of the same name (we got
318 # here, so there isn't), return it.
320 if (not tied %_sourcetobinary) {
321 tie %_sourcetobinary, MLDBM => $config{source_binary_map}, O_RDONLY or
322 die "Unable top open $gSourceBinaryMap for reading";
324 for my $maybe_sourcepkg (@binaries) {
325 if (exists $_sourcetobinary{$maybe_sourcepkg}) {
326 push @source,[$maybe_sourcepkg,$_] for keys %{$_sourcetobinary{$maybe_sourcepkg}};
329 # if @source is still empty here, it's probably a non-existant
330 # source package, so don't return anything.
335 if ($param{source_only}) {
337 for my $s (@source) {
338 # we shouldn't need to do this, but do this temporarily to
340 next unless defined $s->[0];
343 @result = sort keys %uniq;
344 if ($param{scalar_only}) {
345 @result = join(', ',@result);
350 for my $s (@source) {
351 $uniq{$s->[0]}{$s->[1]} = 1;
353 for my $sn (sort keys %uniq) {
354 push @result, [$sn, $_] for sort keys %{$uniq{$sn}};
358 # No $gBinarySourceMap, or it didn't have an entry for this name and
360 $param{cache}{$cache_key} = \@result;
361 return $param{scalar_only} ? $result[0] : @result;
364 =head2 sourcetobinary
366 Returns a list of references to triplets of binary package names, versions,
367 and architectures corresponding to a given source package name and version.
368 If the given source package name and version cannot be found in the database
369 but the source package name is in the unversioned package-to-source map
370 file, then a reference to a binary package name and version pair will be
371 returned, without the architecture.
376 my ($srcname, $srcver) = @_;
378 if (not tied %_sourcetobinary) {
379 tie %_sourcetobinary, MLDBM => $config{source_binary_map}, O_RDONLY or
380 die "Unable top open $config{source_binary_map} for reading";
385 # avoid autovivification
386 my $source = $_sourcetobinary{$srcname};
387 return () unless defined $source;
388 if (exists $source->{$srcver}) {
389 my $bin = $source->{$srcver};
390 return () unless defined $bin;
393 # No $gSourceBinaryMap, or it didn't have an entry for this name and
394 # version. Try $gPackageSource (unversioned) instead.
395 my @srcpkgs = getsrcpkgs($srcname);
396 return map [$_, $srcver], @srcpkgs;
401 Returns versions of the package in a distribution at a specific
407 my ($pkg, $dist, $arch) = @_;
408 return get_versions(package=>$pkg,
410 defined $arch ? (arch => $arch):(),
418 get_versions(package=>'foopkg',
423 Returns a list of the versions of package in the distributions and
424 architectures listed. This routine only returns unique values.
428 =item package -- package to return list of versions
430 =item dist -- distribution (unstable, stable, testing); can be an
433 =item arch -- architecture (i386, source, ...); can be an arrayref
435 =item time -- returns a version=>time hash at which the newest package
436 matching this version was uploaded
438 =item source -- returns source/version instead of just versions
440 =item no_source_arch -- discards the source architecture when arch is
441 not passed. [Used for finding the versions of binary packages only.]
442 Defaults to 0, which does not discard the source architecture. (This
443 may change in the future, so if you care, please code accordingly.)
445 =item return_archs -- returns a version=>[archs] hash indicating which
446 architectures are at which versions.
448 =item largest_source_version_only -- if there is more than one source
449 version in a particular distribution, discards all versions but the
450 largest in that distribution. Defaults to 1, as this used to be the
451 way that the Debian archive worked.
455 When called in scalar context, this function will return hashrefs or
456 arrayrefs as appropriate, in list context, it will return paired lists
457 or unpaired lists as appropriate.
465 my %param = validate_with(params => \@_,
466 spec => {package => {type => SCALAR|ARRAYREF,
468 dist => {type => SCALAR|ARRAYREF,
469 default => 'unstable',
471 arch => {type => SCALAR|ARRAYREF,
474 time => {type => BOOLEAN,
477 source => {type => BOOLEAN,
480 no_source_arch => {type => BOOLEAN,
483 return_archs => {type => BOOLEAN,
486 largest_source_version_only => {type => BOOLEAN,
493 return () if not defined $gVersionTimeIndex;
494 unless (tied %_versions_time) {
495 tie %_versions_time, 'MLDBM', $gVersionTimeIndex, O_RDONLY
496 or die "can't open versions index $gVersionTimeIndex: $!";
498 $versions = \%_versions_time;
501 return () if not defined $gVersionIndex;
502 unless (tied %_versions) {
503 tie %_versions, 'MLDBM', $gVersionIndex, O_RDONLY
504 or die "can't open versions index $gVersionIndex: $!";
506 $versions = \%_versions;
509 for my $package (make_list($param{package})) {
511 if ($package =~ s/^src://) {
514 my $version = $versions->{$package};
515 next unless defined $version;
516 for my $dist (make_list($param{dist})) {
517 for my $arch (exists $param{arch}?
518 make_list($param{arch}):
519 (grep {not $param{no_source_arch} or
521 } $source_only?'source':keys %{$version->{$dist}})) {
522 next unless defined $version->{$dist}{$arch};
523 my @vers = ref $version->{$dist}{$arch} eq 'HASH' ?
524 keys %{$version->{$dist}{$arch}} :
525 make_list($version->{$dist}{$arch});
526 if ($param{largest_source_version_only} and
527 $arch eq 'source' and @vers > 1) {
528 # order the versions, then pick the biggest version number
529 @vers = sort_versions(@vers);
532 for my $ver (@vers) {
534 if ($param{source}) {
535 ($f_ver) = make_source_versions(package => $package,
538 next unless defined $f_ver;
541 $versions{$f_ver} = max($versions{$f_ver}||0,$version->{$dist}{$arch}{$ver});
544 push @{$versions{$f_ver}},$arch;
550 if ($param{time} or $param{return_archs}) {
551 return wantarray?%versions :\%versions;
553 return wantarray?keys %versions :[keys %versions];
557 =head2 makesourceversions
559 @{$cgi_var{found}} = makesourceversions($cgi_var{package},undef,@{$cgi_var{found}});
561 Canonicalize versions into source versions, which have an explicitly
562 named source package. This is used to cope with source packages whose
563 names have changed during their history, and with cases where source
564 version numbers differ from binary version numbers.
568 our %_sourceversioncache = ();
569 sub makesourceversions {
570 my ($package,$arch,@versions) = @_;
571 die "Package $package is multiple packages; split on , and call makesourceversions multiple times"
573 return make_source_versions(package => $package,
574 (defined $arch)?(arch => $arch):(),
575 versions => \@versions
579 =head2 make_source_versions
581 make_source_versions(package => 'foo',
586 warnings => \$warnings,
589 An extended version of makesourceversions (which calls this function
590 internally) that allows for multiple packages, architectures, and
591 outputs warnings and debugging information to provided SCALARREFs or
594 The guess_source option determines whether the source package is
595 guessed at if there is no obviously correct package. Things that use
596 this function for non-transient output should set this to false,
597 things that use it for transient output can set this to true.
598 Currently it defaults to true, but that is not a sane option.
603 sub make_source_versions {
604 my %param = validate_with(params => \@_,
605 spec => {package => {type => SCALAR|ARRAYREF,
607 arch => {type => SCALAR|ARRAYREF|UNDEF,
610 versions => {type => SCALAR|ARRAYREF,
613 guess_source => {type => BOOLEAN,
616 source_version_cache => {type => HASHREF,
619 debug => {type => SCALARREF|HANDLE,
622 warnings => {type => SCALARREF|HANDLE,
627 my ($warnings) = globify_scalar(exists $param{warnings}?$param{warnings}:undef);
628 my ($debug) = globify_scalar(exists $param{debug} ?$param{debug} :undef);
630 my @packages = grep {defined $_ and length $_ } make_list($param{package});
631 my @archs = grep {defined $_ } make_list ($param{arch});
635 if (not exists $param{source_version_cache}) {
636 $param{source_version_cache} = \%_sourceversioncache;
638 if (grep {/,/} make_list($param{package})) {
639 croak "Package names contain ,; split on /,/ and call make_source_versions with an arrayref of packages"
642 for my $version (make_list($param{versions})) {
643 if ($version =~ m{(.+)/([^/]+)$}) {
644 # Already a source version.
645 $sourceversions{$version} = 1;
646 next unless exists $param{warnings};
647 # check to see if this source version is even possible
648 my @bin_versions = sourcetobinary($1,$2);
649 if (not @bin_versions or
650 @{$bin_versions[0]} != 3) {
651 print {$warnings} "The source $1 and version $2 do not appear to match any binary packages\n";
655 croak "You must provide at least one package if the versions are not fully qualified";
657 for my $pkg (@packages) {
658 if ($pkg =~ /^src:(.+)/) {
659 $sourceversions{"$1/$version"} = 1;
660 next unless exists $param{warnings};
661 # check to see if this source version is even possible
662 my @bin_versions = sourcetobinary($1,$version);
663 if (not @bin_versions or
664 @{$bin_versions[0]} != 3) {
665 print {$warnings} "The source '$1' and version '$version' do not appear to match any binary packages\n";
669 for my $arch (@archs) {
670 my $cachearch = (defined $arch) ? $arch : '';
671 my $cachekey = "$pkg/$cachearch/$version";
672 if (exists($param{source_version_cache}{$cachekey})) {
673 for my $v (@{$param{source_version_cache}{$cachekey}}) {
674 $sourceversions{$v} = 1;
678 elsif ($param{guess_source} and
679 exists$param{source_version_cache}{$cachekey.'/guess'}) {
680 for my $v (@{$param{source_version_cache}{$cachekey.'/guess'}}) {
681 $sourceversions{$v} = 1;
685 my @srcinfo = binary_to_source(binary => $pkg,
687 length($arch)?(arch => $arch):());
689 # We don't have explicit information about the
690 # binary-to-source mapping for this version
692 print {$warnings} "There is no source info for the package '$pkg' at version '$version' with architecture '$arch'\n";
693 if ($param{guess_source}) {
695 my $pkgsrc = getpkgsrc();
696 if (exists $pkgsrc->{$pkg}) {
697 @srcinfo = ([$pkgsrc->{$pkg}, $version]);
698 } elsif (getsrcpkgs($pkg)) {
699 # If we're looking at a source package
700 # that doesn't have a binary of the
701 # same name, just try the same
703 @srcinfo = ([$pkg, $version]);
707 # store guesses in a slightly different location
708 $param{source_version_cache}{$cachekey.'/guess'} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
712 # only store this if we didn't have to guess it
713 $param{source_version_cache}{$cachekey} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
715 $sourceversions{"$_->[0]/$_->[1]"} = 1 foreach @srcinfo;
720 return sort keys %sourceversions;