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.)
270 my %param = validate_with(params => \@_,
271 spec => {package => {type => SCALAR|ARRAYREF,
273 dist => {type => SCALAR|ARRAYREF,
274 default => 'unstable',
276 arch => {type => SCALAR|ARRAYREF,
279 time => {type => BOOLEAN,
282 source => {type => BOOLEAN,
285 no_source_arch => {type => BOOLEAN,
292 return () if not defined $gVersionTimeIndex;
293 unless (tied %_versions_time) {
294 tie %_versions_time, 'MLDBM', $gVersionTimeIndex, O_RDONLY
295 or die "can't open versions index $gVersionTimeIndex: $!";
297 $versions = \%_versions_time;
300 return () if not defined $gVersionIndex;
301 unless (tied %_versions) {
302 tie %_versions, 'MLDBM', $gVersionIndex, O_RDONLY
303 or die "can't open versions index $gVersionIndex: $!";
305 $versions = \%_versions;
308 for my $package (make_list($param{package})) {
309 my $version = $versions->{$package};
310 next unless defined $version;
311 for my $dist (make_list($param{dist})) {
312 for my $arch (exists $param{arch}?
313 make_list($param{arch}):
314 (grep {not $param{no_source_arch} or
316 } keys %{$version->{$dist}})) {
317 next unless defined $version->{$dist}{$arch};
318 for my $ver (ref $version->{$dist}{$arch} ?
319 keys %{$version->{$dist}{$arch}} :
320 $version->{$dist}{$arch}
323 if ($param{source}) {
324 ($f_ver) = makesourceversions($package,$arch,$ver);
325 next unless defined $f_ver;
328 $versions{$f_ver} = max($versions{$f_ver}||0,$version->{$dist}{$arch}{$ver});
331 $versions{$f_ver} = 1;
340 return keys %versions;
344 =item makesourceversions
346 @{$cgi_var{found}} = makesourceversions($cgi_var{package},undef,@{$cgi_var{found}});
348 Canonicalize versions into source versions, which have an explicitly
349 named source package. This is used to cope with source packages whose
350 names have changed during their history, and with cases where source
351 version numbers differ from binary version numbers.
355 our %_sourceversioncache = ();
356 sub makesourceversions {
360 die "Package $pkg is multiple packages; split on , and call makesourceversions multiple times"
363 for my $version (@_) {
364 if ($version =~ m[/]) {
365 # Already a source version.
366 $sourceversions{$version} = 1;
368 my $cachearch = (defined $arch) ? $arch : '';
369 my $cachekey = "$pkg/$cachearch/$version";
370 if (exists($_sourceversioncache{$cachekey})) {
371 for my $v (@{$_sourceversioncache{$cachekey}}) {
372 $sourceversions{$v} = 1;
377 my @srcinfo = binarytosource($pkg, $version, $arch);
379 # We don't have explicit information about the
380 # binary-to-source mapping for this version (yet). Since
381 # this is a CGI script and our output is transient, we can
382 # get away with just looking in the unversioned map; if it's
383 # wrong (as it will be when binary and source package
384 # versions differ), too bad.
385 my $pkgsrc = getpkgsrc();
386 if (exists $pkgsrc->{$pkg}) {
387 @srcinfo = ([$pkgsrc->{$pkg}, $version]);
388 } elsif (getsrcpkgs($pkg)) {
389 # If we're looking at a source package that doesn't have
390 # a binary of the same name, just try the same version.
391 @srcinfo = ([$pkg, $version]);
396 $sourceversions{"$_->[0]/$_->[1]"} = 1 foreach @srcinfo;
397 $_sourceversioncache{$cachekey} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
401 return sort keys %sourceversions;