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 Debbugs::Config qw(:config :globals);
17 use base qw(Exporter);
18 use vars qw($VERSION @EXPORT_OK %EXPORT_TAGS @EXPORT);
24 %EXPORT_TAGS = (versions => [qw(getversions get_versions)],
25 mapping => [qw(getpkgsrc getpkgcomponent getsrcpkgs),
26 qw(binarytosource sourcetobinary makesourceversions)
30 Exporter::export_ok_tags(qw(versions mapping));
31 $EXPORT_TAGS{all} = [@EXPORT_OK];
34 use Fcntl qw(O_RDONLY);
35 use MLDBM qw(DB_File Storable);
36 use Storable qw(dclone);
37 use Params::Validate qw(validate_with :types);
38 use Debbugs::Common qw(make_list);
40 use List::Util qw(min max);
42 $MLDBM::DumpMeth = 'portable';
43 $MLDBM::RemoveTaint = 1;
47 Debbugs::Packages - debbugs binary/source package handling
51 The Debbugs::Packages module provides support functions to map binary
52 packages to their corresponding source packages and vice versa. (This makes
53 sense for software distributions, where developers may work on a single
54 source package which produces several binary packages for use by users; it
55 may not make sense in other contexts.)
63 Returns a reference to a hash of binary package names to their corresponding
72 return $_pkgsrc if $_pkgsrc;
73 return {} unless defined $Debbugs::Packages::gPackageSource;
78 open(MM,"$Debbugs::Packages::gPackageSource")
79 or die("open $Debbugs::Packages::gPackageSource: $!");
81 next unless m/^(\S+)\s+(\S+)\s+(\S.*\S)\s*$/;
82 my ($bin,$cmp,$src)=($1,$2,$3);
85 push @{$srcpkg{$src}}, $bin;
86 $pkgcomponent{$bin}= $cmp;
90 $_pkgcomponent = \%pkgcomponent;
97 Returns a reference to a hash of binary package names to the component of
98 the archive containing those binary packages (e.g. "main", "contrib",
103 sub getpkgcomponent {
104 return $_pkgcomponent if $_pkgcomponent;
106 return $_pkgcomponent;
111 Returns a list of the binary packages produced by a given source package.
117 getpkgsrc() if not defined $_srcpkg;
118 return () if not defined $src or not exists $_srcpkg->{$src};
119 return @{$_srcpkg->{$src}};
124 Returns a reference to the source package name and version pair
125 corresponding to a given binary package name, version, and architecture. If
126 undef is passed as the architecture, returns a list of references to all
127 possible pairs of source package names and versions for all architectures,
128 with any duplicates removed.
132 our %_binarytosource;
134 my ($binname, $binver, $binarch) = @_;
136 # TODO: This gets hit a lot, especially from buggyversion() - probably
137 # need an extra cache for speed here.
138 return () unless defined $gBinarySourceMap;
140 if (not tied %_binarytosource) {
141 tie %_binarytosource, MLDBM => $gBinarySourceMap, O_RDONLY or
142 die "Unable to open $gBinarySourceMap for reading";
145 # avoid autovivification
146 my $binary = $_binarytosource{$binname};
147 return () unless defined $binary;
148 my %binary = %{$binary};
149 if (exists $binary{$binver}) {
150 if (defined $binarch) {
151 my $src = $binary{$binver}{$binarch};
152 return () unless defined $src; # not on this arch
153 # Copy the data to avoid tiedness problems.
156 # Get (srcname, srcver) pairs for all architectures and
157 # remove any duplicates. This involves some slightly tricky
158 # multidimensional hashing; sorry. Fortunately there'll
159 # usually only be one pair returned.
161 for my $ar (keys %{$binary{$binver}}) {
162 my $src = $binary{$binver}{$ar};
163 next unless defined $src;
164 $uniq{$src->[0]}{$src->[1]} = 1;
167 for my $sn (sort keys %uniq) {
168 push @uniq, [$sn, $_] for sort keys %{$uniq{$sn}};
174 # No $gBinarySourceMap, or it didn't have an entry for this name and
181 Returns a list of references to triplets of binary package names, versions,
182 and architectures corresponding to a given source package name and version.
183 If the given source package name and version cannot be found in the database
184 but the source package name is in the unversioned package-to-source map
185 file, then a reference to a binary package name and version pair will be
186 returned, without the architecture.
190 our %_sourcetobinary;
192 my ($srcname, $srcver) = @_;
194 if (not tied %_sourcetobinary) {
195 tie %_sourcetobinary, MLDBM => $gSourceBinaryMap, O_RDONLY or
196 die "Unable top open $gSourceBinaryMap for reading";
201 # avoid autovivification
202 my $source = $_sourcetobinary{$srcname};
203 return () unless defined $source;
204 my %source = %{$source};
205 if (exists $source{$srcver}) {
206 my $bin = $source{$srcver};
207 return () unless defined $bin;
210 # No $gSourceBinaryMap, or it didn't have an entry for this name and
211 # version. Try $gPackageSource (unversioned) instead.
212 my @srcpkgs = getsrcpkgs($srcname);
213 return map [$_, $srcver], @srcpkgs;
218 Returns versions of the package in a distribution at a specific
224 my ($pkg, $dist, $arch) = @_;
225 return get_versions(package=>$pkg,
227 defined $arch ? (arch => $arch):(),
235 get_version(package=>'foopkg',
240 Returns a list of the versions of package in the distributions and
241 architectures listed. This routine only returns unique values.
245 =item package -- package to return list of versions
247 =item dist -- distribution (unstable, stable, testing); can be an
250 =item arch -- architecture (i386, source, ...); can be an arrayref
252 =item time -- returns a version=>time hash at which the newest package
253 matching this version was uploaded
255 =item source -- returns source/version instead of just versions
257 =item no_source_arch -- discards the source architecture when arch is
258 not passed. [Used for finding the versions of binary packages only.]
259 Defaults to 0, which does not discard the source architecture. (This
260 may change in the future, so if you care, please code accordingly.)
262 =item return_archs -- returns a version=>[archs] hash indicating which
263 architectures are at which versions.
273 my %param = validate_with(params => \@_,
274 spec => {package => {type => SCALAR|ARRAYREF,
276 dist => {type => SCALAR|ARRAYREF,
277 default => 'unstable',
279 arch => {type => SCALAR|ARRAYREF,
282 time => {type => BOOLEAN,
285 source => {type => BOOLEAN,
288 no_source_arch => {type => BOOLEAN,
291 return_archs => {type => BOOLEAN,
298 return () if not defined $gVersionTimeIndex;
299 unless (tied %_versions_time) {
300 tie %_versions_time, 'MLDBM', $gVersionTimeIndex, O_RDONLY
301 or die "can't open versions index $gVersionTimeIndex: $!";
303 $versions = \%_versions_time;
306 return () if not defined $gVersionIndex;
307 unless (tied %_versions) {
308 tie %_versions, 'MLDBM', $gVersionIndex, O_RDONLY
309 or die "can't open versions index $gVersionIndex: $!";
311 $versions = \%_versions;
314 for my $package (make_list($param{package})) {
315 my $version = $versions->{$package};
316 next unless defined $version;
317 for my $dist (make_list($param{dist})) {
318 for my $arch (exists $param{arch}?
319 make_list($param{arch}):
320 (grep {not $param{no_source_arch} or
322 } keys %{$version->{$dist}})) {
323 next unless defined $version->{$dist}{$arch};
324 for my $ver (ref $version->{$dist}{$arch} ?
325 keys %{$version->{$dist}{$arch}} :
326 $version->{$dist}{$arch}
329 if ($param{source}) {
330 ($f_ver) = makesourceversions($package,$arch,$ver);
331 next unless defined $f_ver;
334 $versions{$f_ver} = max($versions{$f_ver}||0,$version->{$dist}{$arch}{$ver});
337 push @{$versions{$f_ver}},$arch;
346 elsif ($param{return_archs}) {
349 return keys %versions;
353 =item makesourceversions
355 @{$cgi_var{found}} = makesourceversions($cgi_var{package},undef,@{$cgi_var{found}});
357 Canonicalize versions into source versions, which have an explicitly
358 named source package. This is used to cope with source packages whose
359 names have changed during their history, and with cases where source
360 version numbers differ from binary version numbers.
364 our %_sourceversioncache = ();
365 sub makesourceversions {
369 die "Package $pkg is multiple packages; split on , and call makesourceversions multiple times"
372 for my $version (@_) {
373 if ($version =~ m[/]) {
374 # Already a source version.
375 $sourceversions{$version} = 1;
377 my $cachearch = (defined $arch) ? $arch : '';
378 my $cachekey = "$pkg/$cachearch/$version";
379 if (exists($_sourceversioncache{$cachekey})) {
380 for my $v (@{$_sourceversioncache{$cachekey}}) {
381 $sourceversions{$v} = 1;
386 my @srcinfo = binarytosource($pkg, $version, $arch);
388 # We don't have explicit information about the
389 # binary-to-source mapping for this version (yet). Since
390 # this is a CGI script and our output is transient, we can
391 # get away with just looking in the unversioned map; if it's
392 # wrong (as it will be when binary and source package
393 # versions differ), too bad.
394 my $pkgsrc = getpkgsrc();
395 if (exists $pkgsrc->{$pkg}) {
396 @srcinfo = ([$pkgsrc->{$pkg}, $version]);
397 } elsif (getsrcpkgs($pkg)) {
398 # If we're looking at a source package that doesn't have
399 # a binary of the same name, just try the same version.
400 @srcinfo = ([$pkg, $version]);
405 $sourceversions{"$_->[0]/$_->[1]"} = 1 foreach @srcinfo;
406 $_sourceversioncache{$cachekey} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
410 return sort keys %sourceversions;