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);
18 use Debbugs::Config qw(:config :globals);
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);
44 $MLDBM::DumpMeth = 'portable';
45 $MLDBM::RemoveTaint = 1;
49 Debbugs::Packages - debbugs binary/source package handling
53 The Debbugs::Packages module provides support functions to map binary
54 packages to their corresponding source packages and vice versa. (This makes
55 sense for software distributions, where developers may work on a single
56 source package which produces several binary packages for use by users; it
57 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;
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}};
126 Returns a reference to the source package name and version pair
127 corresponding to a given binary package name, version, and architecture.
129 If undef is passed as the architecture, returns a list of references
130 to all possible pairs of source package names and versions for all
131 architectures, with any duplicates removed.
133 If the binary version is not passed either, returns a list of possible
134 source package names for all architectures at all versions, with any
139 our %_binarytosource;
141 my ($binname, $binver, $binarch) = @_;
143 # TODO: This gets hit a lot, especially from buggyversion() - probably
144 # need an extra cache for speed here.
145 return () unless defined $gBinarySourceMap;
147 if (not tied %_binarytosource) {
148 tie %_binarytosource, MLDBM => $gBinarySourceMap, O_RDONLY or
149 die "Unable to open $gBinarySourceMap for reading";
152 # avoid autovivification
153 my $binary = $_binarytosource{$binname};
154 return () unless defined $binary;
155 my %binary = %{$binary};
156 if (not defined $binver) {
158 for my $ver (keys %binary) {
159 for my $ar (keys %{$binary{$ver}}) {
160 my $src = $binary{$ver}{$ar};
161 next unless defined $src;
162 $uniq{$src->[0]} = 1;
167 elsif (exists $binary{$binver}) {
168 if (defined $binarch) {
169 my $src = $binary{$binver}{$binarch};
170 return () unless defined $src; # not on this arch
171 # Copy the data to avoid tiedness problems.
174 # Get (srcname, srcver) pairs for all architectures and
175 # remove any duplicates. This involves some slightly tricky
176 # multidimensional hashing; sorry. Fortunately there'll
177 # usually only be one pair returned.
179 for my $ar (keys %{$binary{$binver}}) {
180 my $src = $binary{$binver}{$ar};
181 next unless defined $src;
182 $uniq{$src->[0]}{$src->[1]} = 1;
185 for my $sn (sort keys %uniq) {
186 push @uniq, [$sn, $_] for sort keys %{$uniq{$sn}};
192 # No $gBinarySourceMap, or it didn't have an entry for this name and
199 Returns a list of references to triplets of binary package names, versions,
200 and architectures corresponding to a given source package name and version.
201 If the given source package name and version cannot be found in the database
202 but the source package name is in the unversioned package-to-source map
203 file, then a reference to a binary package name and version pair will be
204 returned, without the architecture.
208 our %_sourcetobinary;
210 my ($srcname, $srcver) = @_;
212 if (not tied %_sourcetobinary) {
213 tie %_sourcetobinary, MLDBM => $gSourceBinaryMap, O_RDONLY or
214 die "Unable top open $gSourceBinaryMap for reading";
219 # avoid autovivification
220 my $source = $_sourcetobinary{$srcname};
221 return () unless defined $source;
222 my %source = %{$source};
223 if (exists $source{$srcver}) {
224 my $bin = $source{$srcver};
225 return () unless defined $bin;
228 # No $gSourceBinaryMap, or it didn't have an entry for this name and
229 # version. Try $gPackageSource (unversioned) instead.
230 my @srcpkgs = getsrcpkgs($srcname);
231 return map [$_, $srcver], @srcpkgs;
236 Returns versions of the package in a distribution at a specific
242 my ($pkg, $dist, $arch) = @_;
243 return get_versions(package=>$pkg,
245 defined $arch ? (arch => $arch):(),
253 get_versions(package=>'foopkg',
258 Returns a list of the versions of package in the distributions and
259 architectures listed. This routine only returns unique values.
263 =item package -- package to return list of versions
265 =item dist -- distribution (unstable, stable, testing); can be an
268 =item arch -- architecture (i386, source, ...); can be an arrayref
270 =item time -- returns a version=>time hash at which the newest package
271 matching this version was uploaded
273 =item source -- returns source/version instead of just versions
275 =item no_source_arch -- discards the source architecture when arch is
276 not passed. [Used for finding the versions of binary packages only.]
277 Defaults to 0, which does not discard the source architecture. (This
278 may change in the future, so if you care, please code accordingly.)
280 =item return_archs -- returns a version=>[archs] hash indicating which
281 architectures are at which versions.
285 When called in scalar context, this function will return hashrefs or
286 arrayrefs as appropriate, in list context, it will return paired lists
287 or unpaired lists as appropriate.
295 my %param = validate_with(params => \@_,
296 spec => {package => {type => SCALAR|ARRAYREF,
298 dist => {type => SCALAR|ARRAYREF,
299 default => 'unstable',
301 arch => {type => SCALAR|ARRAYREF,
304 time => {type => BOOLEAN,
307 source => {type => BOOLEAN,
310 no_source_arch => {type => BOOLEAN,
313 return_archs => {type => BOOLEAN,
320 return () if not defined $gVersionTimeIndex;
321 unless (tied %_versions_time) {
322 tie %_versions_time, 'MLDBM', $gVersionTimeIndex, O_RDONLY
323 or die "can't open versions index $gVersionTimeIndex: $!";
325 $versions = \%_versions_time;
328 return () if not defined $gVersionIndex;
329 unless (tied %_versions) {
330 tie %_versions, 'MLDBM', $gVersionIndex, O_RDONLY
331 or die "can't open versions index $gVersionIndex: $!";
333 $versions = \%_versions;
336 for my $package (make_list($param{package})) {
337 my $version = $versions->{$package};
338 next unless defined $version;
339 for my $dist (make_list($param{dist})) {
340 for my $arch (exists $param{arch}?
341 make_list($param{arch}):
342 (grep {not $param{no_source_arch} or
344 } keys %{$version->{$dist}})) {
345 next unless defined $version->{$dist}{$arch};
346 for my $ver (ref $version->{$dist}{$arch} ?
347 keys %{$version->{$dist}{$arch}} :
348 $version->{$dist}{$arch}
351 if ($param{source}) {
352 ($f_ver) = makesourceversions($package,$arch,$ver);
353 next unless defined $f_ver;
356 $versions{$f_ver} = max($versions{$f_ver}||0,$version->{$dist}{$arch}{$ver});
359 push @{$versions{$f_ver}},$arch;
365 if ($param{time} or $param{return_archs}) {
366 return wantarray?%versions :\%versions;
368 return wantarray?keys %versions :[keys %versions];
372 =item makesourceversions
374 @{$cgi_var{found}} = makesourceversions($cgi_var{package},undef,@{$cgi_var{found}});
376 Canonicalize versions into source versions, which have an explicitly
377 named source package. This is used to cope with source packages whose
378 names have changed during their history, and with cases where source
379 version numbers differ from binary version numbers.
383 our %_sourceversioncache = ();
384 sub makesourceversions {
388 die "Package $pkg is multiple packages; split on , and call makesourceversions multiple times"
391 for my $version (@_) {
392 if ($version =~ m[/]) {
393 # Already a source version.
394 $sourceversions{$version} = 1;
396 my $cachearch = (defined $arch) ? $arch : '';
397 my $cachekey = "$pkg/$cachearch/$version";
398 if (exists($_sourceversioncache{$cachekey})) {
399 for my $v (@{$_sourceversioncache{$cachekey}}) {
400 $sourceversions{$v} = 1;
405 my @srcinfo = binarytosource($pkg, $version, $arch);
407 # We don't have explicit information about the
408 # binary-to-source mapping for this version (yet). Since
409 # this is a CGI script and our output is transient, we can
410 # get away with just looking in the unversioned map; if it's
411 # wrong (as it will be when binary and source package
412 # versions differ), too bad.
413 my $pkgsrc = getpkgsrc();
414 if (exists $pkgsrc->{$pkg}) {
415 @srcinfo = ([$pkgsrc->{$pkg}, $version]);
416 } elsif (getsrcpkgs($pkg)) {
417 # If we're looking at a source package that doesn't have
418 # a binary of the same name, just try the same version.
419 @srcinfo = ([$pkg, $version]);
424 $sourceversions{"$_->[0]/$_->[1]"} = 1 foreach @srcinfo;
425 $_sourceversioncache{$cachekey} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
429 return sort keys %sourceversions;