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
265 my %param = validate_with(params => \@_,
266 spec => {package => {type => SCALAR,
268 dist => {type => SCALAR|ARRAYREF,
269 default => 'unstable',
271 arch => {type => SCALAR|ARRAYREF,
274 time => {type => BOOLEAN,
277 source => {type => BOOLEAN,
284 return () if not defined $gVersionTimeIndex;
285 unless (tied %_versions_time) {
286 tie %_versions_time, 'MLDBM', $gVersionTimeIndex, O_RDONLY
287 or die "can't open versions index $gVersionTimeIndex: $!";
289 $versions = \%_versions_time;
292 return () if not defined $gVersionIndex;
293 unless (tied %_versions) {
294 tie %_versions, 'MLDBM', $gVersionIndex, O_RDONLY
295 or die "can't open versions index $gVersionIndex: $!";
297 $versions = \%_versions;
300 for my $package (make_list($param{package})) {
301 my $version = $versions->{$package};
302 next unless defined $version;
303 for my $dist (make_list($param{dist})) {
304 for my $arch (exists $param{arch}?
305 make_list($param{arch}):
306 (keys %{$version->{$dist}})) {
307 next unless defined $version->{$dist}{$arch};
308 for my $ver (ref $version->{$dist}{$arch} ?
309 keys %{$version->{$dist}{$arch}} :
310 $version->{$dist}{$arch}
313 if ($param{source}) {
314 ($f_ver) = makesourceversions($package,$arch,$ver);
317 $versions{$f_ver} = max($versions{$f_ver}||0,$version->{$dist}{$arch}{$ver});
320 $versions{$f_ver} = 1;
329 return keys %versions;
333 =item makesourceversions
335 @{$cgi_var{found}} = makesourceversions($cgi_var{package},undef,@{$cgi_var{found}});
337 Canonicalize versions into source versions, which have an explicitly
338 named source package. This is used to cope with source packages whose
339 names have changed during their history, and with cases where source
340 version numbers differ from binary version numbers.
344 our %_sourceversioncache = ();
345 sub makesourceversions {
349 die "Package $pkg is multiple packages; split on , and call makesourceversions multiple times"
352 for my $version (@_) {
353 if ($version =~ m[/]) {
354 # Already a source version.
355 $sourceversions{$version} = 1;
357 my $cachearch = (defined $arch) ? $arch : '';
358 my $cachekey = "$pkg/$cachearch/$version";
359 if (exists($_sourceversioncache{$cachekey})) {
360 for my $v (@{$_sourceversioncache{$cachekey}}) {
361 $sourceversions{$v} = 1;
366 my @srcinfo = binarytosource($pkg, $version, $arch);
368 # We don't have explicit information about the
369 # binary-to-source mapping for this version (yet). Since
370 # this is a CGI script and our output is transient, we can
371 # get away with just looking in the unversioned map; if it's
372 # wrong (as it will be when binary and source package
373 # versions differ), too bad.
374 my $pkgsrc = getpkgsrc();
375 if (exists $pkgsrc->{$pkg}) {
376 @srcinfo = ([$pkgsrc->{$pkg}, $version]);
377 } elsif (getsrcpkgs($pkg)) {
378 # If we're looking at a source package that doesn't have
379 # a binary of the same name, just try the same version.
380 @srcinfo = ([$pkg, $version]);
385 $sourceversions{"$_->[0]/$_->[1]"} = 1 foreach @srcinfo;
386 $_sourceversioncache{$cachekey} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
390 return sort keys %sourceversions;