]> git.donarmstrong.com Git - debbugs.git/blob - Debbugs/Packages.pm
only pass arch to binary_to_source if it has length
[debbugs.git] / Debbugs / Packages.pm
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.
5 #
6 # [Other people have contributed to this file; their copyrights should
7 # go here too.]
8 # Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
9
10 package Debbugs::Packages;
11
12 use warnings;
13 use strict;
14
15 use base qw(Exporter);
16 use vars qw($VERSION @EXPORT_OK %EXPORT_TAGS @EXPORT);
17
18 use Carp;
19
20 use Debbugs::Config qw(:config :globals);
21
22 BEGIN {
23     $VERSION = 1.00;
24
25      @EXPORT = ();
26      %EXPORT_TAGS = (versions => [qw(getversions get_versions make_source_versions)],
27                      mapping  => [qw(getpkgsrc getpkgcomponent getsrcpkgs),
28                                   qw(binary_to_source sourcetobinary makesourceversions)
29                                  ],
30                     );
31      @EXPORT_OK = ();
32      Exporter::export_ok_tags(qw(versions mapping));
33      $EXPORT_TAGS{all} = [@EXPORT_OK];
34 }
35
36 use Fcntl qw(O_RDONLY);
37 use MLDBM qw(DB_File Storable);
38 use Storable qw(dclone);
39 use Params::Validate qw(validate_with :types);
40 use Debbugs::Common qw(make_list globify_scalar);
41
42 use List::Util qw(min max);
43
44 use IO::File;
45
46 $MLDBM::DumpMeth = 'portable';
47 $MLDBM::RemoveTaint = 1;
48
49 =head1 NAME
50
51 Debbugs::Packages - debbugs binary/source package handling
52
53 =head1 DESCRIPTION
54
55 The Debbugs::Packages module provides support functions to map binary
56 packages to their corresponding source packages and vice versa. (This makes
57 sense for software distributions, where developers may work on a single
58 source package which produces several binary packages for use by users; it
59 may not make sense in other contexts.)
60
61 =head1 METHODS
62
63 =head2 getpkgsrc
64
65 Returns a reference to a hash of binary package names to their corresponding
66 source package names.
67
68 =cut
69
70 our $_pkgsrc;
71 our $_pkgcomponent;
72 our $_srcpkg;
73 sub getpkgsrc {
74     return $_pkgsrc if $_pkgsrc;
75     return {} unless defined $Debbugs::Packages::gPackageSource;
76     my %pkgsrc;
77     my %pkgcomponent;
78     my %srcpkg;
79
80     my $fh = IO::File->new($config{package_source},'r')
81         or die("Unable to open $config{package_source} for reading: $!");
82     while(<$fh>) {
83         next unless m/^(\S+)\s+(\S+)\s+(\S.*\S)\s*$/;
84         my ($bin,$cmp,$src)=($1,$2,$3);
85         $bin = lc($bin);
86         $pkgsrc{$bin}= $src;
87         push @{$srcpkg{$src}}, $bin;
88         $pkgcomponent{$bin}= $cmp;
89     }
90     close($fh);
91     $_pkgsrc = \%pkgsrc;
92     $_pkgcomponent = \%pkgcomponent;
93     $_srcpkg = \%srcpkg;
94     return $_pkgsrc;
95 }
96
97 =head2 getpkgcomponent
98
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",
101 "non-free").
102
103 =cut
104
105 sub getpkgcomponent {
106     return $_pkgcomponent if $_pkgcomponent;
107     getpkgsrc();
108     return $_pkgcomponent;
109 }
110
111 =head2 getsrcpkgs
112
113 Returns a list of the binary packages produced by a given source package.
114
115 =cut
116
117 sub getsrcpkgs {
118     my $src = shift;
119     getpkgsrc() if not defined $_srcpkg;
120     return () if not defined $src or not exists $_srcpkg->{$src};
121     return @{$_srcpkg->{$src}};
122 }
123
124 =head2 binary_to_source
125
126      binary_to_source(package => 'foo',
127                       version => '1.2.3',
128                       arch    => 'i386');
129
130
131 Turn a binary package (at optional version in optional architecture)
132 into a single (or set) of source packages (optionally) with associated
133 versions.
134
135 By default, in LIST context, returns a LIST of array refs of source
136 package, source version pairs corresponding to the binary package(s),
137 arch(s), and verion(s) passed.
138
139 In SCALAR context, only the corresponding source packages are
140 returned, concatenated with ', ' if necessary.
141
142 If no source can be found, returns undef in scalar context, or the
143 empty list in list context.
144
145 =over
146
147 =item binary -- binary package name(s) as a SCALAR or ARRAYREF
148
149 =item version -- binary package version(s) as a SCALAR or ARRAYREF;
150 optional, defaults to all versions.
151
152 =item arch -- binary package architecture(s) as a SCALAR or ARRAYREF;
153 optional, defaults to all architectures.
154
155 =item source_only -- return only the source name (forced on if in
156 SCALAR context), defaults to false.
157
158 =item scalar_only -- return a scalar only (forced true if in SCALAR
159 context, also causes source_only to be true), defaults to false.
160
161 =item cache -- optional HASHREF to be used to cache results of
162 binary_to_source.
163
164 =back
165
166 =cut
167
168 # the two global variables below are used to tie the source maps; we
169 # probably should be retying them in long lived processes.
170 our %_binarytosource;
171 our %_sourcetobinary;
172 sub binary_to_source{
173     my %param = validate_with(params => \@_,
174                               spec   => {binary => {type => SCALAR|ARRAYREF,
175                                                     },
176                                          version => {type => SCALAR|ARRAYREF,
177                                                      optional => 1,
178                                                     },
179                                          arch    => {type => SCALAR|ARRAYREF,
180                                                      optional => 1,
181                                                     },
182                                          source_only => {default => 0,
183                                                         },
184                                          scalar_only => {default => 0,
185                                                         },
186                                          cache => {type => HASHREF,
187                                                    default => {},
188                                                   },
189                                         },
190                              );
191
192     # TODO: This gets hit a lot, especially from buggyversion() - probably
193     # need an extra cache for speed here.
194     return () unless defined $gBinarySourceMap;
195
196     if ($param{scalar_only} or not wantarray) {
197         $param{source_only} = 1;
198         $param{scalar_only} = 1;
199     }
200
201     my @source;
202     my @binaries = grep {defined $_} make_list(exists $param{binary}?$param{binary}:[]);
203     my @versions = grep {defined $_} make_list(exists $param{version}?$param{version}:[]);
204     my @archs = grep {defined $_} make_list(exists $param{arch}?$param{arch}:[]);
205     return () unless @binaries;
206     my $cache_key = join("\1",
207                          join("\0",@binaries),
208                          join("\0",@versions),
209                          join("\0",@archs),
210                          join("\0",@param{qw(source_only scalar_only)}));
211     if (exists $param{cache}{$cache_key}) {
212         return $param{scalar_only} ? $param{cache}{$cache_key}[0]:
213             @{$param{cache}{$cache_key}};
214     }
215     for my $binary (@binaries) {
216         if ($binary =~ m/^src:(.+)$/) {
217             push @source,[$1,''];
218             next;
219         }
220         if (not tied %_binarytosource) {
221             tie %_binarytosource, MLDBM => $config{binary_source_map}, O_RDONLY or
222                 die "Unable to open $config{binary_source_map} for reading";
223         }
224         # avoid autovivification
225         my $bin = $_binarytosource{$binary};
226         if (not @versions) {
227             next unless defined $bin;
228             for my $ver (keys %{$bin}) {
229                 for my $ar (keys %{$bin->{$ver}}) {
230                     my $src = $bin->{$ver}{$ar};
231                     next unless defined $src;
232                     push @source,[$src->[0],$src->[1]];
233                 }
234             }
235         }
236         else {
237             my $found_one_version = 0;
238             for my $version (@versions) {
239                 next unless exists $bin->{$version};
240                 if (exists $bin->{$version}{all}) {
241                     push @source,dclone($bin->{$version}{all});
242                     next;
243                 }
244                 my @t_archs;
245                 if (@archs) {
246                     @t_archs = @archs;
247                 }
248                 else {
249                     @t_archs = keys %{$bin->{$version}};
250                 }
251                 for my $arch (@t_archs) {
252                     push @source,dclone($bin->{$version}{$arch}) if
253                         exists $bin->{$version}{$arch};
254                 }
255             }
256         }
257     }
258
259     if (not @source and not @versions and not @archs) {
260         # ok, we haven't found any results at all. If we weren't given
261         # a specific version and architecture, then we should try
262         # really hard to figure out the right source
263
264         # if any the packages we've been given are a valid source
265         # package name, and there's no binary of the same name (we got
266         # here, so there isn't), return it.
267
268         if (not tied %_sourcetobinary) {
269             tie %_sourcetobinary, MLDBM => $config{source_binary_map}, O_RDONLY or
270                 die "Unable top open $gSourceBinaryMap for reading";
271         }
272         for my $maybe_sourcepkg (@binaries) {
273             if (exists $_sourcetobinary{$maybe_sourcepkg}) {
274                 push @source,[$maybe_sourcepkg,$_] for keys %{$_sourcetobinary{$maybe_sourcepkg}};
275             }
276         }
277         # if @source is still empty here, it's probably a non-existant
278         # source package, so don't return anything.
279     }
280
281     my @result;
282
283     if ($param{source_only}) {
284         my %uniq;
285         for my $s (@source) {
286             $uniq{$s->[0]} = 1;
287         }
288         @result = sort keys %uniq;
289         if ($param{scalar_only}) {
290             @result = join(', ',@result);
291         }
292     }
293     else {
294         my %uniq;
295         for my $s (@source) {
296             $uniq{$s->[0]}{$s->[1]} = 1;
297         }
298         for my $sn (sort keys %uniq) {
299             push @result, [$sn, $_] for sort keys %{$uniq{$sn}};
300         }
301     }
302
303     # No $gBinarySourceMap, or it didn't have an entry for this name and
304     # version.
305     $param{cache}{$cache_key} = \@result;
306     return $param{scalar_only} ? $result[0] : @result;
307 }
308
309 =head2 sourcetobinary
310
311 Returns a list of references to triplets of binary package names, versions,
312 and architectures corresponding to a given source package name and version.
313 If the given source package name and version cannot be found in the database
314 but the source package name is in the unversioned package-to-source map
315 file, then a reference to a binary package name and version pair will be
316 returned, without the architecture.
317
318 =cut
319
320 sub sourcetobinary {
321     my ($srcname, $srcver) = @_;
322
323     if (not tied %_sourcetobinary) {
324         tie %_sourcetobinary, MLDBM => $config{source_binary_map}, O_RDONLY or
325             die "Unable top open $config{source_binary_map} for reading";
326     }
327
328
329
330     # avoid autovivification
331     my $source = $_sourcetobinary{$srcname};
332     return () unless defined $source;
333     if (exists $source->{$srcver}) {
334          my $bin = $source->{$srcver};
335          return () unless defined $bin;
336          return @$bin;
337     }
338     # No $gSourceBinaryMap, or it didn't have an entry for this name and
339     # version. Try $gPackageSource (unversioned) instead.
340     my @srcpkgs = getsrcpkgs($srcname);
341     return map [$_, $srcver], @srcpkgs;
342 }
343
344 =head2 getversions
345
346 Returns versions of the package in a distribution at a specific
347 architecture
348
349 =cut
350
351 sub getversions {
352     my ($pkg, $dist, $arch) = @_;
353     return get_versions(package=>$pkg,
354                         dist => $dist,
355                         defined $arch ? (arch => $arch):(),
356                        );
357 }
358
359
360
361 =head2 get_versions
362
363      get_versions(package=>'foopkg',
364                   dist => 'unstable',
365                   arch => 'i386',
366                  );
367
368 Returns a list of the versions of package in the distributions and
369 architectures listed. This routine only returns unique values.
370
371 =over
372
373 =item package -- package to return list of versions
374
375 =item dist -- distribution (unstable, stable, testing); can be an
376 arrayref
377
378 =item arch -- architecture (i386, source, ...); can be an arrayref
379
380 =item time -- returns a version=>time hash at which the newest package
381 matching this version was uploaded
382
383 =item source -- returns source/version instead of just versions
384
385 =item no_source_arch -- discards the source architecture when arch is
386 not passed. [Used for finding the versions of binary packages only.]
387 Defaults to 0, which does not discard the source architecture. (This
388 may change in the future, so if you care, please code accordingly.)
389
390 =item return_archs -- returns a version=>[archs] hash indicating which
391 architectures are at which versions.
392
393 =back
394
395 When called in scalar context, this function will return hashrefs or
396 arrayrefs as appropriate, in list context, it will return paired lists
397 or unpaired lists as appropriate.
398
399 =cut
400
401 our %_versions;
402 our %_versions_time;
403
404 sub get_versions{
405      my %param = validate_with(params => \@_,
406                                 spec   => {package => {type => SCALAR|ARRAYREF,
407                                                       },
408                                            dist    => {type => SCALAR|ARRAYREF,
409                                                        default => 'unstable',
410                                                       },
411                                            arch    => {type => SCALAR|ARRAYREF,
412                                                        optional => 1,
413                                                       },
414                                            time    => {type    => BOOLEAN,
415                                                        default => 0,
416                                                       },
417                                            source  => {type    => BOOLEAN,
418                                                        default => 0,
419                                                       },
420                                            no_source_arch => {type => BOOLEAN,
421                                                               default => 0,
422                                                              },
423                                            return_archs => {type => BOOLEAN,
424                                                             default => 0,
425                                                            },
426                                           },
427                                );
428      my $versions;
429      if ($param{time}) {
430           return () if not defined $gVersionTimeIndex;
431           unless (tied %_versions_time) {
432                tie %_versions_time, 'MLDBM', $gVersionTimeIndex, O_RDONLY
433                     or die "can't open versions index $gVersionTimeIndex: $!";
434           }
435           $versions = \%_versions_time;
436      }
437      else {
438           return () if not defined $gVersionIndex;
439           unless (tied %_versions) {
440                tie %_versions, 'MLDBM', $gVersionIndex, O_RDONLY
441                     or die "can't open versions index $gVersionIndex: $!";
442           }
443           $versions = \%_versions;
444      }
445      my %versions;
446      for my $package (make_list($param{package})) {
447           my $version = $versions->{$package};
448           next unless defined $version;
449           for my $dist (make_list($param{dist})) {
450                for my $arch (exists $param{arch}?
451                              make_list($param{arch}):
452                              (grep {not $param{no_source_arch} or
453                                         $_ ne 'source'
454                                     } keys %{$version->{$dist}})) {
455                     next unless defined $version->{$dist}{$arch};
456                     for my $ver (ref $version->{$dist}{$arch} ?
457                                  keys %{$version->{$dist}{$arch}} :
458                                  $version->{$dist}{$arch}
459                                 ) {
460                          my $f_ver = $ver;
461                          if ($param{source}) {
462                               ($f_ver) = make_source_versions(package => $package,
463                                                               arch => $arch,
464                                                               versions => $ver);
465                               next unless defined $f_ver;
466                          }
467                          if ($param{time}) {
468                               $versions{$f_ver} = max($versions{$f_ver}||0,$version->{$dist}{$arch}{$ver});
469                          }
470                          else {
471                               push @{$versions{$f_ver}},$arch;
472                          }
473                     }
474                }
475           }
476      }
477      if ($param{time} or $param{return_archs}) {
478           return wantarray?%versions :\%versions;
479      }
480      return wantarray?keys %versions :[keys %versions];
481 }
482
483
484 =head2 makesourceversions
485
486      @{$cgi_var{found}} = makesourceversions($cgi_var{package},undef,@{$cgi_var{found}});
487
488 Canonicalize versions into source versions, which have an explicitly
489 named source package. This is used to cope with source packages whose
490 names have changed during their history, and with cases where source
491 version numbers differ from binary version numbers.
492
493 =cut
494
495 our %_sourceversioncache = ();
496 sub makesourceversions {
497     my ($package,$arch,@versions) = @_;
498     die "Package $package is multiple packages; split on , and call makesourceversions multiple times"
499          if $package =~ /,/;
500     return make_source_versions(package => $package,
501                                 (defined $arch)?(arch => $arch):(),
502                                 versions => \@versions
503                                );
504 }
505
506 =head2 make_source_versions
507
508      make_source_versions(package => 'foo',
509                           arch    => 'source',
510                           versions => '0.1.1',
511                           guess_source => 1,
512                           debug    => \$debug,
513                           warnings => \$warnings,
514                          );
515
516 An extended version of makesourceversions (which calls this function
517 internally) that allows for multiple packages, architectures, and
518 outputs warnings and debugging information to provided SCALARREFs or
519 HANDLEs.
520
521 The guess_source option determines whether the source package is
522 guessed at if there is no obviously correct package. Things that use
523 this function for non-transient output should set this to false,
524 things that use it for transient output can set this to true.
525 Currently it defaults to true, but that is not a sane option.
526
527
528 =cut
529
530 sub make_source_versions {
531     my %param = validate_with(params => \@_,
532                               spec   => {package => {type => SCALAR|ARRAYREF,
533                                                     },
534                                          arch    => {type => SCALAR|ARRAYREF|UNDEF,
535                                                      default => ''
536                                                     },
537                                          versions => {type => SCALAR|ARRAYREF,
538                                                       default => [],
539                                                      },
540                                          guess_source => {type => BOOLEAN,
541                                                           default => 1,
542                                                          },
543                                          source_version_cache => {type => HASHREF,
544                                                                   optional => 1,
545                                                                  },
546                                          debug    => {type => SCALARREF|HANDLE,
547                                                       optional => 1,
548                                                      },
549                                          warnings => {type => SCALARREF|HANDLE,
550                                                       optional => 1,
551                                                      },
552                                         },
553                              );
554     my ($warnings) = globify_scalar(exists $param{warnings}?$param{warnings}:undef);
555     my ($debug)    = globify_scalar(exists $param{debug}   ?$param{debug}   :undef);
556
557     my @packages = grep {defined $_ and length $_ } make_list($param{package});
558     my @archs    = grep {defined $_ } make_list ($param{arch});
559     if (not @archs) {
560         push @archs, '';
561     }
562     if (not exists $param{source_version_cache}) {
563         $param{source_version_cache} = \%_sourceversioncache;
564     }
565     if (grep {/,/} make_list($param{package})) {
566         croak "Package names contain ,; split on /,/ and call make_source_versions with an arrayref of packages"
567     }
568     my %sourceversions;
569     for my $version (make_list($param{versions})) {
570         if ($version =~ m{(.+)/([^/]+)$}) {
571             # Already a source version.
572             $sourceversions{$version} = 1;
573             next unless exists $param{warnings};
574             # check to see if this source version is even possible
575             my @bin_versions = sourcetobinary($1,$2);
576             if (not @bin_versions or
577                 @{$bin_versions[0]} != 3) {
578                 print {$warnings} "The source $1 and version $2 do not appear to match any binary packages\n";
579             }
580         } else {
581             if (not @packages) {
582                 croak "You must provide at least one package if the versions are not fully qualified";
583             }
584             for my $pkg (@packages) {
585                 if ($pkg =~ /^src:(.+)/) {
586                     $sourceversions{"$1/$version"} = 1;
587                     next unless exists $param{warnings};
588                     # check to see if this source version is even possible
589                     my @bin_versions = sourcetobinary($1,$version);
590                     if (not @bin_versions or
591                         @{$bin_versions[0]} != 3) {
592                         print {$warnings} "The source $1 and version $2 do not appear to match any binary packages\n";
593                     }
594                     next;
595                 }
596                 for my $arch (@archs) {
597                     my $cachearch = (defined $arch) ? $arch : '';
598                     my $cachekey = "$pkg/$cachearch/$version";
599                     if (exists($param{source_version_cache}{$cachekey})) {
600                         for my $v (@{$param{source_version_cache}{$cachekey}}) {
601                             $sourceversions{$v} = 1;
602                         }
603                         next;
604                     }
605                     elsif ($param{guess_source} and
606                            exists$param{source_version_cache}{$cachekey.'/guess'}) {
607                         for my $v (@{$param{source_version_cache}{$cachekey.'/guess'}}) {
608                             $sourceversions{$v} = 1;
609                         }
610                         next;
611                     }
612                     my @srcinfo = binary_to_source(binary => $pkg,
613                                                    version => $version,
614                                                    length($arch)?(arch    => $arch):());
615                     if (not @srcinfo) {
616                         # We don't have explicit information about the
617                         # binary-to-source mapping for this version
618                         # (yet).
619                         print {$warnings} "There is no source info for the package '$pkg' at version '$version' with architecture '$arch'\n";
620                         if ($param{guess_source}) {
621                             # Lets guess it
622                             my $pkgsrc = getpkgsrc();
623                             if (exists $pkgsrc->{$pkg}) {
624                                 @srcinfo = ([$pkgsrc->{$pkg}, $version]);
625                             } elsif (getsrcpkgs($pkg)) {
626                                 # If we're looking at a source package
627                                 # that doesn't have a binary of the
628                                 # same name, just try the same
629                                 # version.
630                                 @srcinfo = ([$pkg, $version]);
631                             } else {
632                                 next;
633                             }
634                             # store guesses in a slightly different location
635                             $param{source_version_cache}{$cachekey.'/guess'} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
636                         }
637                     }
638                     else {
639                         # only store this if we didn't have to guess it
640                         $param{source_version_cache}{$cachekey} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
641                     }
642                     $sourceversions{"$_->[0]/$_->[1]"} = 1 foreach @srcinfo;
643                 }
644             }
645         }
646     }
647     return sort keys %sourceversions;
648 }
649
650
651
652 1;