1 package Debbugs::Packages;
6 use Debbugs::Config qw(:config :globals);
9 use vars qw($VERSION @EXPORT_OK %EXPORT_TAGS @EXPORT);
15 %EXPORT_TAGS = (versions => [qw(getversions)],
16 mapping => [qw(getpkgsrc getpkgcomponent getsrcpkgs),
17 qw(binarytosource sourcetobinary makesourceversions)
21 Exporter::export_ok_tags(qw(versions mapping));
22 $EXPORT_TAGS{all} = [@EXPORT_OK];
25 use Fcntl qw(O_RDONLY);
26 use MLDBM qw(DB_File Storable);
27 use Storable qw(dclone);
29 $MLDBM::DumpMeth = 'portable';
30 $MLDBM::RemoveTaint = 1;
34 Debbugs::Packages - debbugs binary/source package handling
38 The Debbugs::Packages module provides support functions to map binary
39 packages to their corresponding source packages and vice versa. (This makes
40 sense for software distributions, where developers may work on a single
41 source package which produces several binary packages for use by users; it
42 may not make sense in other contexts.)
50 Returns a reference to a hash of binary package names to their corresponding
59 return $_pkgsrc if $_pkgsrc;
60 return {} unless defined $Debbugs::Packages::gPackageSource;
65 open(MM,"$Debbugs::Packages::gPackageSource")
66 or die("open $Debbugs::Packages::gPackageSource: $!");
68 next unless m/^(\S+)\s+(\S+)\s+(\S.*\S)\s*$/;
69 my ($bin,$cmp,$src)=($1,$2,$3);
72 push @{$srcpkg{$src}}, $bin;
73 $pkgcomponent{$bin}= $cmp;
77 $_pkgcomponent = \%pkgcomponent;
84 Returns a reference to a hash of binary package names to the component of
85 the archive containing those binary packages (e.g. "main", "contrib",
91 return $_pkgcomponent if $_pkgcomponent;
93 return $_pkgcomponent;
98 Returns a list of the binary packages produced by a given source package.
104 getpkgsrc() if not defined $_srcpkg;
105 return () if not defined $src or not exists $_srcpkg->{$src};
106 return @{$_srcpkg->{$src}};
111 Returns a reference to the source package name and version pair
112 corresponding to a given binary package name, version, and architecture. If
113 undef is passed as the architecture, returns a list of references to all
114 possible pairs of source package names and versions for all architectures,
115 with any duplicates removed.
121 my ($binname, $binver, $binarch) = @_;
123 # TODO: This gets hit a lot, especially from buggyversion() - probably
124 # need an extra cache for speed here.
125 return () unless defined $gBinarySourceMap;
127 if (tied %_binarytosource or
128 tie %_binarytosource, 'MLDBM',
129 $gBinarySourceMap, O_RDONLY) {
130 # avoid autovivification
131 my $binary = $_binarytosource{$binname};
132 return () unless defined $binary;
133 my %binary = %{$binary};
134 if (exists $binary{$binver}) {
135 if (defined $binarch) {
136 my $src = $binary{$binver}{$binarch};
137 return () unless defined $src; # not on this arch
138 # Copy the data to avoid tiedness problems.
141 # Get (srcname, srcver) pairs for all architectures and
142 # remove any duplicates. This involves some slightly tricky
143 # multidimensional hashing; sorry. Fortunately there'll
144 # usually only be one pair returned.
146 for my $ar (keys %{$binary{$binver}}) {
147 my $src = $binary{$binver}{$ar};
148 next unless defined $src;
149 $uniq{$src->[0]}{$src->[1]} = 1;
152 for my $sn (sort keys %uniq) {
153 push @uniq, [$sn, $_] for sort keys %{$uniq{$sn}};
160 # No $gBinarySourceMap, or it didn't have an entry for this name and
167 Returns a list of references to triplets of binary package names, versions,
168 and architectures corresponding to a given source package name and version.
169 If the given source package name and version cannot be found in the database
170 but the source package name is in the unversioned package-to-source map
171 file, then a reference to a binary package name and version pair will be
172 returned, without the architecture.
178 my ($srcname, $srcver) = @_;
180 if (tied %_sourcetobinary or
181 tie %_sourcetobinary, 'MLDBM',
182 $gSourceBinaryMap, O_RDONLY) {
183 # avoid autovivification
184 my $source = $_sourcetobinary{$srcname};
185 return () unless defined $source;
186 my %source = %{$source};
187 if (exists $source{$srcver}) {
188 my $bin = $source{$srcver};
189 return () unless defined $bin;
194 # No $gSourceBinaryMap, or it didn't have an entry for this name and
195 # version. Try $gPackageSource (unversioned) instead.
196 my @srcpkgs = getsrcpkgs($srcname);
197 return map [$_, $srcver], @srcpkgs;
202 Returns versions of the package in a distribution at a specific
209 my ($pkg, $dist, $arch) = @_;
210 return () unless defined $gVersionIndex;
211 $dist = 'unstable' unless defined $dist;
213 unless (tied %_versions) {
214 tie %_versions, 'MLDBM', $gVersionIndex, O_RDONLY
215 or die "can't open versions index: $!";
217 my $version = $_versions{$pkg};
218 return () unless defined $version;
219 my %version = %{$version};
221 if (defined $arch and exists $version{$dist}{$arch}) {
222 my $ver = $version{$pkg}{$dist}{$arch};
223 return $ver if defined $ver;
227 for my $ar (keys %{$version{$dist}}) {
228 $uniq{$version{$dist}{$ar}} = 1 unless $ar eq 'source';
232 } elsif (exists $version{$dist}{source}) {
233 # Maybe this is actually a source package with no corresponding
235 return $version{$dist}{source};
243 =item makesourceversions
245 @{$cgi_var{found}} = makesourceversions($cgi_var{package},undef,@{$cgi_var{found}});
247 Canonicalize versions into source versions, which have an explicitly
248 named source package. This is used to cope with source packages whose
249 names have changed during their history, and with cases where source
250 version numbers differ from binary version numbers.
254 my %_sourceversioncache = ();
255 sub makesourceversions {
260 for my $version (@_) {
261 if ($version =~ m[/]) {
262 # Already a source version.
263 $sourceversions{$version} = 1;
265 my $cachearch = (defined $arch) ? $arch : '';
266 my $cachekey = "$pkg/$cachearch/$version";
267 if (exists($_sourceversioncache{$cachekey})) {
268 for my $v (@{$_sourceversioncache{$cachekey}}) {
269 $sourceversions{$v} = 1;
274 my @srcinfo = binarytosource($pkg, $version, $arch);
276 # We don't have explicit information about the
277 # binary-to-source mapping for this version (yet). Since
278 # this is a CGI script and our output is transient, we can
279 # get away with just looking in the unversioned map; if it's
280 # wrong (as it will be when binary and source package
281 # versions differ), too bad.
282 my $pkgsrc = getpkgsrc();
283 if (exists $pkgsrc->{$pkg}) {
284 @srcinfo = ([$pkgsrc->{$pkg}, $version]);
285 } elsif (getsrcpkgs($pkg)) {
286 # If we're looking at a source package that doesn't have
287 # a binary of the same name, just try the same version.
288 @srcinfo = ([$pkg, $version]);
293 $sourceversions{"$_->[0]/$_->[1]"} = 1 foreach @srcinfo;
294 $_sourceversioncache{$cachekey} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
298 return sort keys %sourceversions;