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),
33 Exporter::export_ok_tags(qw(versions mapping));
34 $EXPORT_TAGS{all} = [@EXPORT_OK];
37 use Fcntl qw(O_RDONLY);
38 use MLDBM qw(DB_File Storable);
39 use Storable qw(dclone);
40 use Params::Validate qw(validate_with :types);
41 use Debbugs::Common qw(make_list globify_scalar sort_versions);
43 use List::AllUtils qw(min max uniq);
47 $MLDBM::DumpMeth = 'portable';
48 $MLDBM::RemoveTaint = 1;
52 Debbugs::Packages - debbugs binary/source package handling
56 The Debbugs::Packages module provides support functions to map binary
57 packages to their corresponding source packages and vice versa. (This makes
58 sense for software distributions, where developers may work on a single
59 source package which produces several binary packages for use by users; it
60 may not make sense in other contexts.)
66 Returns a reference to a hash of binary package names to their corresponding
75 return $_pkgsrc if $_pkgsrc;
76 return {} unless defined $config{package_source} and
77 length $config{package_source};
82 my $fh = IO::File->new($config{package_source},'r')
83 or croak("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;
99 =head2 getpkgcomponent
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}};
126 =head2 binary_to_source
128 binary_to_source(package => 'foo',
133 Turn a binary package (at optional version in optional architecture)
134 into a single (or set) of source packages (optionally) with associated
137 By default, in LIST context, returns a LIST of array refs of source
138 package, source version pairs corresponding to the binary package(s),
139 arch(s), and verion(s) passed.
141 In SCALAR context, only the corresponding source packages are
142 returned, concatenated with ', ' if necessary.
144 If no source can be found, returns undef in scalar context, or the
145 empty list in list context.
149 =item binary -- binary package name(s) as a SCALAR or ARRAYREF
151 =item version -- binary package version(s) as a SCALAR or ARRAYREF;
152 optional, defaults to all versions.
154 =item arch -- binary package architecture(s) as a SCALAR or ARRAYREF;
155 optional, defaults to all architectures.
157 =item source_only -- return only the source name (forced on if in
158 SCALAR context), defaults to false.
160 =item scalar_only -- return a scalar only (forced true if in SCALAR
161 context, also causes source_only to be true), defaults to false.
163 =item cache -- optional HASHREF to be used to cache results of
170 # the two global variables below are used to tie the source maps; we
171 # probably should be retying them in long lived processes.
172 our %_binarytosource;
173 sub _tie_binarytosource {
174 if (not tied %_binarytosource) {
175 tie %_binarytosource, MLDBM => $config{binary_source_map}, O_RDONLY or
176 die "Unable to open $config{binary_source_map} for reading";
179 our %_sourcetobinary;
180 sub _tie_sourcetobinary {
181 if (not tied %_sourcetobinary) {
182 tie %_sourcetobinary, MLDBM => $config{source_binary_map}, O_RDONLY or
183 die "Unable to open $config{source_binary_map} for reading";
186 sub binary_to_source{
187 my %param = validate_with(params => \@_,
188 spec => {binary => {type => SCALAR|ARRAYREF,
190 version => {type => SCALAR|ARRAYREF,
193 arch => {type => SCALAR|ARRAYREF,
196 source_only => {default => 0,
198 scalar_only => {default => 0,
200 cache => {type => HASHREF,
203 schema => {type => OBJECT,
209 # TODO: This gets hit a lot, especially from buggyversion() - probably
210 # need an extra cache for speed here.
211 return () unless defined $gBinarySourceMap or defined $param{schema};
213 if ($param{scalar_only} or not wantarray) {
214 $param{source_only} = 1;
215 $param{scalar_only} = 1;
219 my @binaries = grep {defined $_} make_list(exists $param{binary}?$param{binary}:[]);
220 my @versions = grep {defined $_} make_list(exists $param{version}?$param{version}:[]);
221 my @archs = grep {defined $_} make_list(exists $param{arch}?$param{arch}:[]);
222 return () unless @binaries;
224 # any src:foo is source package foo with unspecified version
225 @source = map {/^src:(.+)$/?
226 [$1,'']:()} @binaries;
227 @binaries = grep {$_ !~ /^src:/} @binaries;
228 if ($param{schema}) {
229 if ($param{source_only}) {
230 @source = map {$_->[0]} @source;
231 my $src_rs = $param{schema}->resultset('SrcPkg')->
232 search_rs({'bin_pkg.pkg' => [@binaries],
233 @versions?('bin_vers.ver' => [@versions]):(),
234 @archs?('arch.arch' => [@archs]):(),
236 {join => {'src_vers'=>
237 {'bin_vers'=> ['arch','bin_pkg']}
239 columns => [qw(pkg)],
240 order_by => [qw(pkg)],
241 result_class => 'DBIx::Class::ResultClass::HashRefInflator',
246 map {$_->{pkg}} $src_rs->all;
247 if ($param{scalar_only}) {
248 return join(',',@source);
253 my $src_rs = $param{schema}->resultset('SrcVer')->
254 search_rs({'bin_pkg.pkg' => [@binaries],
255 @versions?('bin_vers.ver' => [@versions]):(),
256 @archs?('arch.arch' => [@archs]):(),
259 {'bin_vers' => ['arch','binpkg']},
261 columns => ['src_pkg.pkg','src_ver.ver'],
262 result_class => 'DBIx::Class::ResultClass::HashRefInflator',
263 order_by => ['src_pkg.pkg','src_ver.ver'],
268 map {[$_->{src_pkg}{pkg},
271 if (not @source and not @versions and not @archs) {
272 $src_rs = $param{schema}->resultset('SrcPkg')->
273 search_rs({pkg => [@binaries]},
274 {join => ['src_vers'],
275 columns => ['src_pkg.pkg','src_vers.ver'],
280 map {[$_->{src_pkg}{pkg},
286 my $cache_key = join("\1",
287 join("\0",@binaries),
288 join("\0",@versions),
290 join("\0",@param{qw(source_only scalar_only)}));
291 if (exists $param{cache}{$cache_key}) {
292 return $param{scalar_only} ? $param{cache}{$cache_key}[0]:
293 @{$param{cache}{$cache_key}};
295 for my $binary (@binaries) {
297 # avoid autovivification
298 my $bin = $_binarytosource{$binary};
299 next unless defined $bin;
301 for my $ver (keys %{$bin}) {
302 for my $ar (keys %{$bin->{$ver}}) {
303 my $src = $bin->{$ver}{$ar};
304 next unless defined $src;
305 push @source,[$src->[0],$src->[1]];
310 for my $version (@versions) {
311 next unless exists $bin->{$version};
312 if (exists $bin->{$version}{all}) {
313 push @source,dclone($bin->{$version}{all});
321 @t_archs = keys %{$bin->{$version}};
323 for my $arch (@t_archs) {
324 push @source,dclone($bin->{$version}{$arch}) if
325 exists $bin->{$version}{$arch};
331 if (not @source and not @versions and not @archs) {
332 # ok, we haven't found any results at all. If we weren't given
333 # a specific version and architecture, then we should try
334 # really hard to figure out the right source
336 # if any the packages we've been given are a valid source
337 # package name, and there's no binary of the same name (we got
338 # here, so there isn't), return it.
339 _tie_sourcetobinary();
340 for my $maybe_sourcepkg (@binaries) {
341 if (exists $_sourcetobinary{$maybe_sourcepkg}) {
342 push @source,[$maybe_sourcepkg,$_] for keys %{$_sourcetobinary{$maybe_sourcepkg}};
345 # if @source is still empty here, it's probably a non-existant
346 # source package, so don't return anything.
351 if ($param{source_only}) {
353 for my $s (@source) {
354 # we shouldn't need to do this, but do this temporarily to
356 next unless defined $s->[0];
359 @result = sort keys %uniq;
360 if ($param{scalar_only}) {
361 @result = join(', ',@result);
366 for my $s (@source) {
367 $uniq{$s->[0]}{$s->[1]} = 1;
369 for my $sn (sort keys %uniq) {
370 push @result, [$sn, $_] for sort keys %{$uniq{$sn}};
374 # No $gBinarySourceMap, or it didn't have an entry for this name and
376 $param{cache}{$cache_key} = \@result;
377 return $param{scalar_only} ? $result[0] : @result;
380 =head2 source_to_binary
382 source_to_binary(package => 'foo',
387 Turn a source package (at optional version) into a single (or set) of all binary
388 packages (optionally) with associated versions.
390 By default, in LIST context, returns a LIST of array refs of binary package,
391 binary version, architecture triples corresponding to the source package(s) and
394 In SCALAR context, only the corresponding binary packages are returned,
395 concatenated with ', ' if necessary.
397 If no binaries can be found, returns undef in scalar context, or the
398 empty list in list context.
402 =item source -- source package name(s) as a SCALAR or ARRAYREF
404 =item version -- binary package version(s) as a SCALAR or ARRAYREF;
405 optional, defaults to all versions.
407 =item arch -- binary package architecture(s) as a SCALAR or ARRAYREF;
408 optional, defaults to all architectures.
410 =item binary_only -- return only the source name (forced on if in SCALAR
411 context), defaults to false. [If in LIST context, returns a list of binary
414 =item scalar_only -- return a scalar only (forced true if in SCALAR
415 context, also causes binary_only to be true), defaults to false.
417 =item cache -- optional HASHREF to be used to cache results of
424 # the two global variables below are used to tie the source maps; we
425 # probably should be retying them in long lived processes.
426 sub source_to_binary{
427 my %param = validate_with(params => \@_,
428 spec => {source => {type => SCALAR|ARRAYREF,
430 version => {type => SCALAR|ARRAYREF,
433 binary_only => {default => 0,
435 scalar_only => {default => 0,
437 cache => {type => HASHREF,
440 schema => {type => OBJECT,
445 if (not defined $config{source_binary_map} and
446 not defined $param{schema}
451 if ($param{scalar_only} or not wantarray) {
452 $param{binary_only} = 1;
453 $param{scalar_only} = 1;
457 my @sources = sort grep {defined $_}
458 make_list(exists $param{source}?$param{source}:[]);
459 my @versions = sort grep {defined $_}
460 make_list(exists $param{version}?$param{version}:[]);
461 return () unless @sources;
463 # any src:foo is source package foo with unspecified version
464 @sources = map {s/^src://; $_} @sources;
465 if ($param{schema}) {
466 if ($param{binary_only}) {
467 my $bin_rs = $param{schema}->resultset('BinPkg')->
468 search_rs({'src_pkg.pkg' => [@sources],
469 @versions?('src_ver.ver' => [@versions]):(),
471 {join => {'bin_vers'=>
472 {'src_ver'=> 'src_pkg'}
474 columns => [qw(pkg)],
475 order_by => [qw(pkg)],
476 result_class => 'DBIx::Class::ResultClass::HashRefInflator',
481 map {$_->{pkg}} $bin_rs->all;
482 if ($param{scalar_only}) {
483 return join(', ',@binaries);
488 my $src_rs = $param{schema}->resultset('BinVer')->
489 search_rs({'src_pkg.pkg' => [@sources],
490 @versions?('src_ver.ver' => [@versions]):(),
494 {'src_ver' => ['src_pkg']},
496 columns => ['src_pkg.pkg','src_ver.ver','arch.arch'],
497 order_by => ['src_pkg.pkg','src_ver.ver','arch.arch'],
498 result_class => 'DBIx::Class::ResultClass::HashRefInflator',
503 map {[$_->{src_pkg}{pkg},
508 if (not @binaries and not @versions) {
509 $src_rs = $param{schema}->resultset('BinPkg')->
510 search_rs({pkg => [@sources]},
511 {join => {'bin_vers' =>
513 {'src_ver'=>'src_pkg'}],
516 result_class => 'DBIx::Class::ResultClass::HashRefInflator',
517 columns => ['src_pkg.pkg','src_ver.ver','arch.arch'],
518 order_by => ['src_pkg.pkg','src_ver.ver','arch.arch'],
522 map {[$_->{src_pkg}{pkg},
529 my $cache_key = join("\1",
531 join("\0",@versions),
532 join("\0",@param{qw(binary_only scalar_only)}));
533 if (exists $param{cache}{$cache_key}) {
534 return $param{scalar_only} ? $param{cache}{$cache_key}[0]:
535 @{$param{cache}{$cache_key}};
539 if ($param{binary_only}) {
540 for my $source (@sources) {
542 # avoid autovivification
543 my $src = $_sourcetobinary{$source};
544 if (not defined $src) {
547 if (exists $_binarytosource{$source}) {
548 $binaries{$source} = 1;
552 my @src_vers = @versions;
554 @src_vers = keys %{$src};
556 for my $ver (@src_vers) {
557 $binaries{$_->[0]} = 1
558 foreach @{$src->{$ver}//[]};
561 # return if we have any results.
562 @return = sort keys %binaries;
563 if ($param{scalar_only}) {
564 @return = join(', ',@return);
568 for my $source (@sources) {
570 my $src = $_sourcetobinary{$source};
571 # there isn't a source package, so return this as a binary packages if a
572 # version hasn't been specified
573 if (not defined $src) {
576 if (exists $_binarytosource{$source}) {
577 my $bin = $_binarytosource{$source};
578 for my $ver (keys %{$bin}) {
579 for my $arch (keys %{$bin->{$ver}}) {
580 $binaries{$bin}{$ver}{$arch} = 1;
586 for my $bin_ver_archs (values %{$src}) {
587 for my $bva (@{$bin_ver_archs}) {
588 $binaries{$bva->[0]}{$bva->[1]}{$bva->[2]} = 1;
592 for my $bin (sort keys %binaries) {
593 for my $ver (sort keys %{$binaries{$bin}}) {
594 for my $arch (sort keys %{$binaries{$bin}{$ver}}) {
601 $param{cache}{$cache_key} = \@return;
602 return $param{scalar_only} ? $return[0] : @return;
606 =head2 sourcetobinary
608 Returns a list of references to triplets of binary package names, versions,
609 and architectures corresponding to a given source package name and version.
610 If the given source package name and version cannot be found in the database
611 but the source package name is in the unversioned package-to-source map
612 file, then a reference to a binary package name and version pair will be
613 returned, without the architecture.
618 my ($srcname, $srcver) = @_;
620 # avoid autovivification
621 my $source = $_sourcetobinary{$srcname};
622 return () unless defined $source;
623 if (exists $source->{$srcver}) {
624 my $bin = $source->{$srcver};
625 return () unless defined $bin;
628 # No $gSourceBinaryMap, or it didn't have an entry for this name and
629 # version. Try $gPackageSource (unversioned) instead.
630 my @srcpkgs = getsrcpkgs($srcname);
631 return map [$_, $srcver], @srcpkgs;
636 Returns versions of the package in a distribution at a specific
642 my ($pkg, $dist, $arch) = @_;
643 return get_versions(package=>$pkg,
645 defined $arch ? (arch => $arch):(),
653 get_versions(package=>'foopkg',
658 Returns a list of the versions of package in the distributions and
659 architectures listed. This routine only returns unique values.
663 =item package -- package to return list of versions
665 =item dist -- distribution (unstable, stable, testing); can be an
668 =item arch -- architecture (i386, source, ...); can be an arrayref
670 =item time -- returns a version=>time hash at which the newest package
671 matching this version was uploaded
673 =item source -- returns source/version instead of just versions
675 =item no_source_arch -- discards the source architecture when arch is
676 not passed. [Used for finding the versions of binary packages only.]
677 Defaults to 0, which does not discard the source architecture. (This
678 may change in the future, so if you care, please code accordingly.)
680 =item return_archs -- returns a version=>[archs] hash indicating which
681 architectures are at which versions.
683 =item largest_source_version_only -- if there is more than one source
684 version in a particular distribution, discards all versions but the
685 largest in that distribution. Defaults to 1, as this used to be the
686 way that the Debian archive worked.
690 When called in scalar context, this function will return hashrefs or
691 arrayrefs as appropriate, in list context, it will return paired lists
692 or unpaired lists as appropriate.
700 my %param = validate_with(params => \@_,
701 spec => {package => {type => SCALAR|ARRAYREF,
703 dist => {type => SCALAR|ARRAYREF,
704 default => 'unstable',
706 arch => {type => SCALAR|ARRAYREF,
709 time => {type => BOOLEAN,
712 source => {type => BOOLEAN,
715 no_source_arch => {type => BOOLEAN,
718 return_archs => {type => BOOLEAN,
721 largest_source_version_only => {type => BOOLEAN,
728 return () if not defined $gVersionTimeIndex;
729 unless (tied %_versions_time) {
730 tie %_versions_time, 'MLDBM', $gVersionTimeIndex, O_RDONLY
731 or die "can't open versions index $gVersionTimeIndex: $!";
733 $versions = \%_versions_time;
736 return () if not defined $gVersionIndex;
737 unless (tied %_versions) {
738 tie %_versions, 'MLDBM', $gVersionIndex, O_RDONLY
739 or die "can't open versions index $gVersionIndex: $!";
741 $versions = \%_versions;
744 for my $package (make_list($param{package})) {
746 if ($package =~ s/^src://) {
749 my $version = $versions->{$package};
750 next unless defined $version;
751 for my $dist (make_list($param{dist})) {
752 for my $arch (exists $param{arch}?
753 make_list($param{arch}):
754 (grep {not $param{no_source_arch} or
756 } $source_only?'source':keys %{$version->{$dist}})) {
757 next unless defined $version->{$dist}{$arch};
758 my @vers = ref $version->{$dist}{$arch} eq 'HASH' ?
759 keys %{$version->{$dist}{$arch}} :
760 make_list($version->{$dist}{$arch});
761 if ($param{largest_source_version_only} and
762 $arch eq 'source' and @vers > 1) {
763 # order the versions, then pick the biggest version number
764 @vers = sort_versions(@vers);
767 for my $ver (@vers) {
769 if ($param{source}) {
770 ($f_ver) = make_source_versions(package => $package,
773 next unless defined $f_ver;
776 $versions{$f_ver} = max($versions{$f_ver}||0,$version->{$dist}{$arch}{$ver});
779 push @{$versions{$f_ver}},$arch;
785 if ($param{time} or $param{return_archs}) {
786 return wantarray?%versions :\%versions;
788 return wantarray?keys %versions :[keys %versions];
792 =head2 makesourceversions
794 @{$cgi_var{found}} = makesourceversions($cgi_var{package},undef,@{$cgi_var{found}});
796 Canonicalize versions into source versions, which have an explicitly
797 named source package. This is used to cope with source packages whose
798 names have changed during their history, and with cases where source
799 version numbers differ from binary version numbers.
803 our %_sourceversioncache = ();
804 sub makesourceversions {
805 my ($package,$arch,@versions) = @_;
806 die "Package $package is multiple packages; split on , and call makesourceversions multiple times"
808 return make_source_versions(package => $package,
809 (defined $arch)?(arch => $arch):(),
810 versions => \@versions
814 =head2 make_source_versions
816 make_source_versions(package => 'foo',
820 warnings => \$warnings,
823 An extended version of makesourceversions (which calls this function
824 internally) that allows for multiple packages, architectures, and
825 outputs warnings and debugging information to provided SCALARREFs or
828 The guess_source option determines whether the source package is
829 guessed at if there is no obviously correct package. Things that use
830 this function for non-transient output should set this to false,
831 things that use it for transient output can set this to true.
832 Currently it defaults to true, but that is not a sane option.
837 sub make_source_versions {
838 my %param = validate_with(params => \@_,
839 spec => {package => {type => SCALAR|ARRAYREF,
841 arch => {type => SCALAR|ARRAYREF|UNDEF,
844 versions => {type => SCALAR|ARRAYREF,
847 guess_source => {type => BOOLEAN,
850 source_version_cache => {type => HASHREF,
853 debug => {type => SCALARREF|HANDLE,
856 warnings => {type => SCALARREF|HANDLE,
861 my ($warnings) = globify_scalar(exists $param{warnings}?$param{warnings}:undef);
863 my @packages = grep {defined $_ and length $_ } make_list($param{package});
864 my @archs = grep {defined $_ } make_list ($param{arch});
868 if (not exists $param{source_version_cache}) {
869 $param{source_version_cache} = \%_sourceversioncache;
871 if (grep {/,/} make_list($param{package})) {
872 croak "Package names contain ,; split on /,/ and call make_source_versions with an arrayref of packages"
875 for my $version (make_list($param{versions})) {
876 if ($version =~ m{(.+)/([^/]+)$}) {
877 # Already a source version.
878 $sourceversions{$version} = 1;
879 next unless exists $param{warnings};
880 # check to see if this source version is even possible
881 my @bin_versions = sourcetobinary($1,$2);
882 if (not @bin_versions or
883 @{$bin_versions[0]} != 3) {
884 print {$warnings} "The source $1 and version $2 do not appear to match any binary packages\n";
888 croak "You must provide at least one package if the versions are not fully qualified";
890 for my $pkg (@packages) {
891 if ($pkg =~ /^src:(.+)/) {
892 $sourceversions{"$1/$version"} = 1;
893 next unless exists $param{warnings};
894 # check to see if this source version is even possible
895 my @bin_versions = sourcetobinary($1,$version);
896 if (not @bin_versions or
897 @{$bin_versions[0]} != 3) {
898 print {$warnings} "The source '$1' and version '$version' do not appear to match any binary packages\n";
902 for my $arch (@archs) {
903 my $cachearch = (defined $arch) ? $arch : '';
904 my $cachekey = "$pkg/$cachearch/$version";
905 if (exists($param{source_version_cache}{$cachekey})) {
906 for my $v (@{$param{source_version_cache}{$cachekey}}) {
907 $sourceversions{$v} = 1;
911 elsif ($param{guess_source} and
912 exists$param{source_version_cache}{$cachekey.'/guess'}) {
913 for my $v (@{$param{source_version_cache}{$cachekey.'/guess'}}) {
914 $sourceversions{$v} = 1;
918 my @srcinfo = binary_to_source(binary => $pkg,
920 length($arch)?(arch => $arch):());
922 # We don't have explicit information about the
923 # binary-to-source mapping for this version
925 print {$warnings} "There is no source info for the package '$pkg' at version '$version' with architecture '$arch'\n";
926 if ($param{guess_source}) {
928 my $pkgsrc = getpkgsrc();
929 if (exists $pkgsrc->{$pkg}) {
930 @srcinfo = ([$pkgsrc->{$pkg}, $version]);
931 } elsif (getsrcpkgs($pkg)) {
932 # If we're looking at a source package
933 # that doesn't have a binary of the
934 # same name, just try the same
936 @srcinfo = ([$pkg, $version]);
940 # store guesses in a slightly different location
941 $param{source_version_cache}{$cachekey.'/guess'} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
945 # only store this if we didn't have to guess it
946 $param{source_version_cache}{$cachekey} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
948 $sourceversions{"$_->[0]/$_->[1]"} = 1 foreach @srcinfo;
953 return sort keys %sourceversions;