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 dist -- list of distributions to return corresponding binary packages for
408 as a SCALAR or ARRAYREF.
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 dist => {type => SCALAR|ARRAYREF,
436 binary_only => {default => 0,
438 scalar_only => {default => 0,
440 cache => {type => HASHREF,
443 schema => {type => OBJECT,
448 if (not defined $config{source_binary_map} and
449 not defined $param{schema}
454 if ($param{scalar_only} or not wantarray) {
455 $param{binary_only} = 1;
456 $param{scalar_only} = 1;
460 my @sources = sort grep {defined $_}
461 make_list(exists $param{source}?$param{source}:[]);
462 my @versions = sort grep {defined $_}
463 make_list(exists $param{version}?$param{version}:[]);
464 return () unless @sources;
466 # any src:foo is source package foo with unspecified version
467 @sources = map {s/^src://; $_} @sources;
468 if ($param{schema}) {
469 if ($param{binary_only}) {
470 my $bin_rs = $param{schema}->resultset('BinPkg')->
471 search_rs({'src_pkg.pkg' => [@sources],
472 @versions?('src_ver.ver' => [@versions]):(),
474 {join => {'bin_vers'=>
475 {'src_ver'=> 'src_pkg'}
477 columns => [qw(pkg)],
478 order_by => [qw(pkg)],
479 result_class => 'DBIx::Class::ResultClass::HashRefInflator',
483 if (exists $param{dist}) {
486 {'suite.codename' => [make_list($param{dist})],
487 'suite.suite_name' => [make_list($param{dist})],
489 {join => {'bin_vers' =>
490 {'bin_associations' =>
496 map {$_->{pkg}} $bin_rs->all;
497 if ($param{scalar_only}) {
498 return join(', ',@binaries);
503 my $src_rs = $param{schema}->resultset('BinVer')->
504 search_rs({'src_pkg.pkg' => [@sources],
505 @versions?('src_ver.ver' => [@versions]):(),
509 {'src_ver' => ['src_pkg']},
511 columns => ['src_pkg.pkg','src_ver.ver','arch.arch'],
512 order_by => ['src_pkg.pkg','src_ver.ver','arch.arch'],
513 result_class => 'DBIx::Class::ResultClass::HashRefInflator',
518 map {[$_->{src_pkg}{pkg},
523 if (not @binaries and not @versions) {
524 $src_rs = $param{schema}->resultset('BinPkg')->
525 search_rs({pkg => [@sources]},
526 {join => {'bin_vers' =>
528 {'src_ver'=>'src_pkg'}],
531 result_class => 'DBIx::Class::ResultClass::HashRefInflator',
532 columns => ['src_pkg.pkg','src_ver.ver','arch.arch'],
533 order_by => ['src_pkg.pkg','src_ver.ver','arch.arch'],
537 map {[$_->{src_pkg}{pkg},
544 my $cache_key = join("\1",
546 join("\0",@versions),
547 join("\0",@param{qw(binary_only scalar_only)}));
548 if (exists $param{cache}{$cache_key}) {
549 return $param{scalar_only} ? $param{cache}{$cache_key}[0]:
550 @{$param{cache}{$cache_key}};
554 if ($param{binary_only}) {
555 for my $source (@sources) {
557 # avoid autovivification
558 my $src = $_sourcetobinary{$source};
559 if (not defined $src) {
562 if (exists $_binarytosource{$source}) {
563 $binaries{$source} = 1;
567 my @src_vers = @versions;
569 @src_vers = keys %{$src};
571 for my $ver (@src_vers) {
572 $binaries{$_->[0]} = 1
573 foreach @{$src->{$ver}//[]};
576 # return if we have any results.
577 @return = sort keys %binaries;
578 if ($param{scalar_only}) {
579 @return = join(', ',@return);
583 for my $source (@sources) {
585 my $src = $_sourcetobinary{$source};
586 # there isn't a source package, so return this as a binary packages if a
587 # version hasn't been specified
588 if (not defined $src) {
591 if (exists $_binarytosource{$source}) {
592 my $bin = $_binarytosource{$source};
593 for my $ver (keys %{$bin}) {
594 for my $arch (keys %{$bin->{$ver}}) {
595 $binaries{$bin}{$ver}{$arch} = 1;
601 for my $bin_ver_archs (values %{$src}) {
602 for my $bva (@{$bin_ver_archs}) {
603 $binaries{$bva->[0]}{$bva->[1]}{$bva->[2]} = 1;
607 for my $bin (sort keys %binaries) {
608 for my $ver (sort keys %{$binaries{$bin}}) {
609 for my $arch (sort keys %{$binaries{$bin}{$ver}}) {
616 $param{cache}{$cache_key} = \@return;
617 return $param{scalar_only} ? $return[0] : @return;
621 =head2 sourcetobinary
623 Returns a list of references to triplets of binary package names, versions,
624 and architectures corresponding to a given source package name and version.
625 If the given source package name and version cannot be found in the database
626 but the source package name is in the unversioned package-to-source map
627 file, then a reference to a binary package name and version pair will be
628 returned, without the architecture.
633 my ($srcname, $srcver) = @_;
635 # avoid autovivification
636 my $source = $_sourcetobinary{$srcname};
637 return () unless defined $source;
638 if (exists $source->{$srcver}) {
639 my $bin = $source->{$srcver};
640 return () unless defined $bin;
643 # No $gSourceBinaryMap, or it didn't have an entry for this name and
644 # version. Try $gPackageSource (unversioned) instead.
645 my @srcpkgs = getsrcpkgs($srcname);
646 return map [$_, $srcver], @srcpkgs;
651 Returns versions of the package in a distribution at a specific
657 my ($pkg, $dist, $arch) = @_;
658 return get_versions(package=>$pkg,
660 defined $arch ? (arch => $arch):(),
668 get_versions(package=>'foopkg',
673 Returns a list of the versions of package in the distributions and
674 architectures listed. This routine only returns unique values.
678 =item package -- package to return list of versions
680 =item dist -- distribution (unstable, stable, testing); can be an
683 =item arch -- architecture (i386, source, ...); can be an arrayref
685 =item time -- returns a version=>time hash at which the newest package
686 matching this version was uploaded
688 =item source -- returns source/version instead of just versions
690 =item no_source_arch -- discards the source architecture when arch is
691 not passed. [Used for finding the versions of binary packages only.]
692 Defaults to 0, which does not discard the source architecture. (This
693 may change in the future, so if you care, please code accordingly.)
695 =item return_archs -- returns a version=>[archs] hash indicating which
696 architectures are at which versions.
698 =item largest_source_version_only -- if there is more than one source
699 version in a particular distribution, discards all versions but the
700 largest in that distribution. Defaults to 1, as this used to be the
701 way that the Debian archive worked.
705 When called in scalar context, this function will return hashrefs or
706 arrayrefs as appropriate, in list context, it will return paired lists
707 or unpaired lists as appropriate.
715 my %param = validate_with(params => \@_,
716 spec => {package => {type => SCALAR|ARRAYREF,
718 dist => {type => SCALAR|ARRAYREF,
719 default => 'unstable',
721 arch => {type => SCALAR|ARRAYREF,
724 time => {type => BOOLEAN,
727 source => {type => BOOLEAN,
730 no_source_arch => {type => BOOLEAN,
733 return_archs => {type => BOOLEAN,
736 largest_source_version_only => {type => BOOLEAN,
743 return () if not defined $gVersionTimeIndex;
744 unless (tied %_versions_time) {
745 tie %_versions_time, 'MLDBM', $gVersionTimeIndex, O_RDONLY
746 or die "can't open versions index $gVersionTimeIndex: $!";
748 $versions = \%_versions_time;
751 return () if not defined $gVersionIndex;
752 unless (tied %_versions) {
753 tie %_versions, 'MLDBM', $gVersionIndex, O_RDONLY
754 or die "can't open versions index $gVersionIndex: $!";
756 $versions = \%_versions;
759 for my $package (make_list($param{package})) {
761 if ($package =~ s/^src://) {
764 my $version = $versions->{$package};
765 next unless defined $version;
766 for my $dist (make_list($param{dist})) {
767 for my $arch (exists $param{arch}?
768 make_list($param{arch}):
769 (grep {not $param{no_source_arch} or
771 } $source_only?'source':keys %{$version->{$dist}})) {
772 next unless defined $version->{$dist}{$arch};
773 my @vers = ref $version->{$dist}{$arch} eq 'HASH' ?
774 keys %{$version->{$dist}{$arch}} :
775 make_list($version->{$dist}{$arch});
776 if ($param{largest_source_version_only} and
777 $arch eq 'source' and @vers > 1) {
778 # order the versions, then pick the biggest version number
779 @vers = sort_versions(@vers);
782 for my $ver (@vers) {
784 if ($param{source}) {
785 ($f_ver) = make_source_versions(package => $package,
788 next unless defined $f_ver;
791 $versions{$f_ver} = max($versions{$f_ver}||0,$version->{$dist}{$arch}{$ver});
794 push @{$versions{$f_ver}},$arch;
800 if ($param{time} or $param{return_archs}) {
801 return wantarray?%versions :\%versions;
803 return wantarray?keys %versions :[keys %versions];
807 =head2 makesourceversions
809 @{$cgi_var{found}} = makesourceversions($cgi_var{package},undef,@{$cgi_var{found}});
811 Canonicalize versions into source versions, which have an explicitly
812 named source package. This is used to cope with source packages whose
813 names have changed during their history, and with cases where source
814 version numbers differ from binary version numbers.
818 our %_sourceversioncache = ();
819 sub makesourceversions {
820 my ($package,$arch,@versions) = @_;
821 die "Package $package is multiple packages; split on , and call makesourceversions multiple times"
823 return make_source_versions(package => $package,
824 (defined $arch)?(arch => $arch):(),
825 versions => \@versions
829 =head2 make_source_versions
831 make_source_versions(package => 'foo',
835 warnings => \$warnings,
838 An extended version of makesourceversions (which calls this function
839 internally) that allows for multiple packages, architectures, and
840 outputs warnings and debugging information to provided SCALARREFs or
843 The guess_source option determines whether the source package is
844 guessed at if there is no obviously correct package. Things that use
845 this function for non-transient output should set this to false,
846 things that use it for transient output can set this to true.
847 Currently it defaults to true, but that is not a sane option.
852 sub make_source_versions {
853 my %param = validate_with(params => \@_,
854 spec => {package => {type => SCALAR|ARRAYREF,
856 arch => {type => SCALAR|ARRAYREF|UNDEF,
859 versions => {type => SCALAR|ARRAYREF,
862 guess_source => {type => BOOLEAN,
865 source_version_cache => {type => HASHREF,
868 debug => {type => SCALARREF|HANDLE,
871 warnings => {type => SCALARREF|HANDLE,
876 my ($warnings) = globify_scalar(exists $param{warnings}?$param{warnings}:undef);
878 my @packages = grep {defined $_ and length $_ } make_list($param{package});
879 my @archs = grep {defined $_ } make_list ($param{arch});
883 if (not exists $param{source_version_cache}) {
884 $param{source_version_cache} = \%_sourceversioncache;
886 if (grep {/,/} make_list($param{package})) {
887 croak "Package names contain ,; split on /,/ and call make_source_versions with an arrayref of packages"
890 for my $version (make_list($param{versions})) {
891 if ($version =~ m{(.+)/([^/]+)$}) {
892 # Already a source version.
893 $sourceversions{$version} = 1;
894 next unless exists $param{warnings};
895 # check to see if this source version is even possible
896 my @bin_versions = sourcetobinary($1,$2);
897 if (not @bin_versions or
898 @{$bin_versions[0]} != 3) {
899 print {$warnings} "The source $1 and version $2 do not appear to match any binary packages\n";
903 croak "You must provide at least one package if the versions are not fully qualified";
905 for my $pkg (@packages) {
906 if ($pkg =~ /^src:(.+)/) {
907 $sourceversions{"$1/$version"} = 1;
908 next unless exists $param{warnings};
909 # check to see if this source version is even possible
910 my @bin_versions = sourcetobinary($1,$version);
911 if (not @bin_versions or
912 @{$bin_versions[0]} != 3) {
913 print {$warnings} "The source '$1' and version '$version' do not appear to match any binary packages\n";
917 for my $arch (@archs) {
918 my $cachearch = (defined $arch) ? $arch : '';
919 my $cachekey = "$pkg/$cachearch/$version";
920 if (exists($param{source_version_cache}{$cachekey})) {
921 for my $v (@{$param{source_version_cache}{$cachekey}}) {
922 $sourceversions{$v} = 1;
926 elsif ($param{guess_source} and
927 exists$param{source_version_cache}{$cachekey.'/guess'}) {
928 for my $v (@{$param{source_version_cache}{$cachekey.'/guess'}}) {
929 $sourceversions{$v} = 1;
933 my @srcinfo = binary_to_source(binary => $pkg,
935 length($arch)?(arch => $arch):());
937 # We don't have explicit information about the
938 # binary-to-source mapping for this version
940 print {$warnings} "There is no source info for the package '$pkg' at version '$version' with architecture '$arch'\n";
941 if ($param{guess_source}) {
943 my $pkgsrc = getpkgsrc();
944 if (exists $pkgsrc->{$pkg}) {
945 @srcinfo = ([$pkgsrc->{$pkg}, $version]);
946 } elsif (getsrcpkgs($pkg)) {
947 # If we're looking at a source package
948 # that doesn't have a binary of the
949 # same name, just try the same
951 @srcinfo = ([$pkg, $version]);
955 # store guesses in a slightly different location
956 $param{source_version_cache}{$cachekey.'/guess'} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
960 # only store this if we didn't have to guess it
961 $param{source_version_cache}{$cachekey} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
963 $sourceversions{"$_->[0]/$_->[1]"} = 1 foreach @srcinfo;
968 return sort keys %sourceversions;