]> git.donarmstrong.com Git - debbugs.git/blob - Debbugs/Packages.pm
skip maintainer files if they are empty *or* undef
[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 Exporter qw(import);
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 sort_versions);
41
42 use List::AllUtils 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 $config{package_source} and
76         length $config{package_source};
77     my %pkgsrc;
78     my %pkgcomponent;
79     my %srcpkg;
80
81     my $fh = IO::File->new($config{package_source},'r')
82         or die("Unable to open $config{package_source} for reading: $!");
83     while(<$fh>) {
84         next unless m/^(\S+)\s+(\S+)\s+(\S.*\S)\s*$/;
85         my ($bin,$cmp,$src)=($1,$2,$3);
86         $bin = lc($bin);
87         $pkgsrc{$bin}= $src;
88         push @{$srcpkg{$src}}, $bin;
89         $pkgcomponent{$bin}= $cmp;
90     }
91     close($fh);
92     $_pkgsrc = \%pkgsrc;
93     $_pkgcomponent = \%pkgcomponent;
94     $_srcpkg = \%srcpkg;
95     return $_pkgsrc;
96 }
97
98 =head2 getpkgcomponent
99
100 Returns a reference to a hash of binary package names to the component of
101 the archive containing those binary packages (e.g. "main", "contrib",
102 "non-free").
103
104 =cut
105
106 sub getpkgcomponent {
107     return $_pkgcomponent if $_pkgcomponent;
108     getpkgsrc();
109     return $_pkgcomponent;
110 }
111
112 =head2 getsrcpkgs
113
114 Returns a list of the binary packages produced by a given source package.
115
116 =cut
117
118 sub getsrcpkgs {
119     my $src = shift;
120     getpkgsrc() if not defined $_srcpkg;
121     return () if not defined $src or not exists $_srcpkg->{$src};
122     return @{$_srcpkg->{$src}};
123 }
124
125 =head2 binary_to_source
126
127      binary_to_source(package => 'foo',
128                       version => '1.2.3',
129                       arch    => 'i386');
130
131
132 Turn a binary package (at optional version in optional architecture)
133 into a single (or set) of source packages (optionally) with associated
134 versions.
135
136 By default, in LIST context, returns a LIST of array refs of source
137 package, source version pairs corresponding to the binary package(s),
138 arch(s), and verion(s) passed.
139
140 In SCALAR context, only the corresponding source packages are
141 returned, concatenated with ', ' if necessary.
142
143 If no source can be found, returns undef in scalar context, or the
144 empty list in list context.
145
146 =over
147
148 =item binary -- binary package name(s) as a SCALAR or ARRAYREF
149
150 =item version -- binary package version(s) as a SCALAR or ARRAYREF;
151 optional, defaults to all versions.
152
153 =item arch -- binary package architecture(s) as a SCALAR or ARRAYREF;
154 optional, defaults to all architectures.
155
156 =item source_only -- return only the source name (forced on if in
157 SCALAR context), defaults to false.
158
159 =item scalar_only -- return a scalar only (forced true if in SCALAR
160 context, also causes source_only to be true), defaults to false.
161
162 =item cache -- optional HASHREF to be used to cache results of
163 binary_to_source.
164
165 =back
166
167 =cut
168
169 # the two global variables below are used to tie the source maps; we
170 # probably should be retying them in long lived processes.
171 our %_binarytosource;
172 our %_sourcetobinary;
173 sub binary_to_source{
174     my %param = validate_with(params => \@_,
175                               spec   => {binary => {type => SCALAR|ARRAYREF,
176                                                     },
177                                          version => {type => SCALAR|ARRAYREF,
178                                                      optional => 1,
179                                                     },
180                                          arch    => {type => SCALAR|ARRAYREF,
181                                                      optional => 1,
182                                                     },
183                                          source_only => {default => 0,
184                                                         },
185                                          scalar_only => {default => 0,
186                                                         },
187                                          cache => {type => HASHREF,
188                                                    default => {},
189                                                   },
190                                         },
191                              );
192
193     # TODO: This gets hit a lot, especially from buggyversion() - probably
194     # need an extra cache for speed here.
195     return () unless defined $gBinarySourceMap;
196
197     if ($param{scalar_only} or not wantarray) {
198         $param{source_only} = 1;
199         $param{scalar_only} = 1;
200     }
201
202     my @source;
203     my @binaries = grep {defined $_} make_list(exists $param{binary}?$param{binary}:[]);
204     my @versions = grep {defined $_} make_list(exists $param{version}?$param{version}:[]);
205     my @archs = grep {defined $_} make_list(exists $param{arch}?$param{arch}:[]);
206     return () unless @binaries;
207     my $cache_key = join("\1",
208                          join("\0",@binaries),
209                          join("\0",@versions),
210                          join("\0",@archs),
211                          join("\0",@param{qw(source_only scalar_only)}));
212     if (exists $param{cache}{$cache_key}) {
213         return $param{scalar_only} ? $param{cache}{$cache_key}[0]:
214             @{$param{cache}{$cache_key}};
215     }
216     for my $binary (@binaries) {
217         if ($binary =~ m/^src:(.+)$/) {
218             push @source,[$1,''];
219             next;
220         }
221         if (not tied %_binarytosource) {
222             tie %_binarytosource, MLDBM => $config{binary_source_map}, O_RDONLY or
223                 die "Unable to open $config{binary_source_map} for reading";
224         }
225         # avoid autovivification
226         my $bin = $_binarytosource{$binary};
227         next unless defined $bin;
228         if (not @versions) {
229             for my $ver (keys %{$bin}) {
230                 for my $ar (keys %{$bin->{$ver}}) {
231                     my $src = $bin->{$ver}{$ar};
232                     next unless defined $src;
233                     push @source,[$src->[0],$src->[1]];
234                 }
235             }
236         }
237         else {
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             # we shouldn't need to do this, but do this temporarily to
287             # stop the warning.
288             next unless defined $s->[0];
289             $uniq{$s->[0]} = 1;
290         }
291         @result = sort keys %uniq;
292         if ($param{scalar_only}) {
293             @result = join(', ',@result);
294         }
295     }
296     else {
297         my %uniq;
298         for my $s (@source) {
299             $uniq{$s->[0]}{$s->[1]} = 1;
300         }
301         for my $sn (sort keys %uniq) {
302             push @result, [$sn, $_] for sort keys %{$uniq{$sn}};
303         }
304     }
305
306     # No $gBinarySourceMap, or it didn't have an entry for this name and
307     # version.
308     $param{cache}{$cache_key} = \@result;
309     return $param{scalar_only} ? $result[0] : @result;
310 }
311
312 =head2 sourcetobinary
313
314 Returns a list of references to triplets of binary package names, versions,
315 and architectures corresponding to a given source package name and version.
316 If the given source package name and version cannot be found in the database
317 but the source package name is in the unversioned package-to-source map
318 file, then a reference to a binary package name and version pair will be
319 returned, without the architecture.
320
321 =cut
322
323 sub sourcetobinary {
324     my ($srcname, $srcver) = @_;
325
326     if (not tied %_sourcetobinary) {
327         tie %_sourcetobinary, MLDBM => $config{source_binary_map}, O_RDONLY or
328             die "Unable top open $config{source_binary_map} for reading";
329     }
330
331
332
333     # avoid autovivification
334     my $source = $_sourcetobinary{$srcname};
335     return () unless defined $source;
336     if (exists $source->{$srcver}) {
337          my $bin = $source->{$srcver};
338          return () unless defined $bin;
339          return @$bin;
340     }
341     # No $gSourceBinaryMap, or it didn't have an entry for this name and
342     # version. Try $gPackageSource (unversioned) instead.
343     my @srcpkgs = getsrcpkgs($srcname);
344     return map [$_, $srcver], @srcpkgs;
345 }
346
347 =head2 getversions
348
349 Returns versions of the package in a distribution at a specific
350 architecture
351
352 =cut
353
354 sub getversions {
355     my ($pkg, $dist, $arch) = @_;
356     return get_versions(package=>$pkg,
357                         dist => $dist,
358                         defined $arch ? (arch => $arch):(),
359                        );
360 }
361
362
363
364 =head2 get_versions
365
366      get_versions(package=>'foopkg',
367                   dist => 'unstable',
368                   arch => 'i386',
369                  );
370
371 Returns a list of the versions of package in the distributions and
372 architectures listed. This routine only returns unique values.
373
374 =over
375
376 =item package -- package to return list of versions
377
378 =item dist -- distribution (unstable, stable, testing); can be an
379 arrayref
380
381 =item arch -- architecture (i386, source, ...); can be an arrayref
382
383 =item time -- returns a version=>time hash at which the newest package
384 matching this version was uploaded
385
386 =item source -- returns source/version instead of just versions
387
388 =item no_source_arch -- discards the source architecture when arch is
389 not passed. [Used for finding the versions of binary packages only.]
390 Defaults to 0, which does not discard the source architecture. (This
391 may change in the future, so if you care, please code accordingly.)
392
393 =item return_archs -- returns a version=>[archs] hash indicating which
394 architectures are at which versions.
395
396 =item largest_source_version_only -- if there is more than one source
397 version in a particular distribution, discards all versions but the
398 largest in that distribution. Defaults to 1, as this used to be the
399 way that the Debian archive worked.
400
401 =back
402
403 When called in scalar context, this function will return hashrefs or
404 arrayrefs as appropriate, in list context, it will return paired lists
405 or unpaired lists as appropriate.
406
407 =cut
408
409 our %_versions;
410 our %_versions_time;
411
412 sub get_versions{
413      my %param = validate_with(params => \@_,
414                                 spec   => {package => {type => SCALAR|ARRAYREF,
415                                                       },
416                                            dist    => {type => SCALAR|ARRAYREF,
417                                                        default => 'unstable',
418                                                       },
419                                            arch    => {type => SCALAR|ARRAYREF,
420                                                        optional => 1,
421                                                       },
422                                            time    => {type    => BOOLEAN,
423                                                        default => 0,
424                                                       },
425                                            source  => {type    => BOOLEAN,
426                                                        default => 0,
427                                                       },
428                                            no_source_arch => {type => BOOLEAN,
429                                                               default => 0,
430                                                              },
431                                            return_archs => {type => BOOLEAN,
432                                                             default => 0,
433                                                            },
434                                            largest_source_version_only => {type => BOOLEAN,
435                                                                        default => 1,
436                                                                           },
437                                           },
438                                );
439      my $versions;
440      if ($param{time}) {
441           return () if not defined $gVersionTimeIndex;
442           unless (tied %_versions_time) {
443                tie %_versions_time, 'MLDBM', $gVersionTimeIndex, O_RDONLY
444                     or die "can't open versions index $gVersionTimeIndex: $!";
445           }
446           $versions = \%_versions_time;
447      }
448      else {
449           return () if not defined $gVersionIndex;
450           unless (tied %_versions) {
451                tie %_versions, 'MLDBM', $gVersionIndex, O_RDONLY
452                     or die "can't open versions index $gVersionIndex: $!";
453           }
454           $versions = \%_versions;
455      }
456      my %versions;
457      for my $package (make_list($param{package})) {
458           my $source_only = 0;
459           if ($package =~ s/^src://) {
460                $source_only = 1;
461           }
462           my $version = $versions->{$package};
463           next unless defined $version;
464           for my $dist (make_list($param{dist})) {
465                for my $arch (exists $param{arch}?
466                              make_list($param{arch}):
467                              (grep {not $param{no_source_arch} or
468                                         $_ ne 'source'
469                                     } $source_only?'source':keys %{$version->{$dist}})) {
470                     next unless defined $version->{$dist}{$arch};
471                     my @vers = ref $version->{$dist}{$arch} eq 'HASH' ?
472                         keys %{$version->{$dist}{$arch}} :
473                             make_list($version->{$dist}{$arch});
474                     if ($param{largest_source_version_only} and
475                         $arch eq 'source' and @vers > 1) {
476                         # order the versions, then pick the biggest version number
477                         @vers = sort_versions(@vers);
478                         @vers = $vers[-1];
479                     }
480                     for my $ver (@vers) {
481                          my $f_ver = $ver;
482                          if ($param{source}) {
483                               ($f_ver) = make_source_versions(package => $package,
484                                                               arch => $arch,
485                                                               versions => $ver);
486                               next unless defined $f_ver;
487                          }
488                          if ($param{time}) {
489                               $versions{$f_ver} = max($versions{$f_ver}||0,$version->{$dist}{$arch}{$ver});
490                          }
491                          else {
492                               push @{$versions{$f_ver}},$arch;
493                          }
494                     }
495                }
496           }
497      }
498      if ($param{time} or $param{return_archs}) {
499           return wantarray?%versions :\%versions;
500      }
501      return wantarray?keys %versions :[keys %versions];
502 }
503
504
505 =head2 makesourceversions
506
507      @{$cgi_var{found}} = makesourceversions($cgi_var{package},undef,@{$cgi_var{found}});
508
509 Canonicalize versions into source versions, which have an explicitly
510 named source package. This is used to cope with source packages whose
511 names have changed during their history, and with cases where source
512 version numbers differ from binary version numbers.
513
514 =cut
515
516 our %_sourceversioncache = ();
517 sub makesourceversions {
518     my ($package,$arch,@versions) = @_;
519     die "Package $package is multiple packages; split on , and call makesourceversions multiple times"
520          if $package =~ /,/;
521     return make_source_versions(package => $package,
522                                 (defined $arch)?(arch => $arch):(),
523                                 versions => \@versions
524                                );
525 }
526
527 =head2 make_source_versions
528
529      make_source_versions(package => 'foo',
530                           arch    => 'source',
531                           versions => '0.1.1',
532                           guess_source => 1,
533                           warnings => \$warnings,
534                          );
535
536 An extended version of makesourceversions (which calls this function
537 internally) that allows for multiple packages, architectures, and
538 outputs warnings and debugging information to provided SCALARREFs or
539 HANDLEs.
540
541 The guess_source option determines whether the source package is
542 guessed at if there is no obviously correct package. Things that use
543 this function for non-transient output should set this to false,
544 things that use it for transient output can set this to true.
545 Currently it defaults to true, but that is not a sane option.
546
547
548 =cut
549
550 sub make_source_versions {
551     my %param = validate_with(params => \@_,
552                               spec   => {package => {type => SCALAR|ARRAYREF,
553                                                     },
554                                          arch    => {type => SCALAR|ARRAYREF|UNDEF,
555                                                      default => ''
556                                                     },
557                                          versions => {type => SCALAR|ARRAYREF,
558                                                       default => [],
559                                                      },
560                                          guess_source => {type => BOOLEAN,
561                                                           default => 1,
562                                                          },
563                                          source_version_cache => {type => HASHREF,
564                                                                   optional => 1,
565                                                                  },
566                                          debug    => {type => SCALARREF|HANDLE,
567                                                       optional => 1,
568                                                      },
569                                          warnings => {type => SCALARREF|HANDLE,
570                                                       optional => 1,
571                                                      },
572                                         },
573                              );
574     my ($warnings) = globify_scalar(exists $param{warnings}?$param{warnings}:undef);
575
576     my @packages = grep {defined $_ and length $_ } make_list($param{package});
577     my @archs    = grep {defined $_ } make_list ($param{arch});
578     if (not @archs) {
579         push @archs, '';
580     }
581     if (not exists $param{source_version_cache}) {
582         $param{source_version_cache} = \%_sourceversioncache;
583     }
584     if (grep {/,/} make_list($param{package})) {
585         croak "Package names contain ,; split on /,/ and call make_source_versions with an arrayref of packages"
586     }
587     my %sourceversions;
588     for my $version (make_list($param{versions})) {
589         if ($version =~ m{(.+)/([^/]+)$}) {
590             # Already a source version.
591             $sourceversions{$version} = 1;
592             next unless exists $param{warnings};
593             # check to see if this source version is even possible
594             my @bin_versions = sourcetobinary($1,$2);
595             if (not @bin_versions or
596                 @{$bin_versions[0]} != 3) {
597                 print {$warnings} "The source $1 and version $2 do not appear to match any binary packages\n";
598             }
599         } else {
600             if (not @packages) {
601                 croak "You must provide at least one package if the versions are not fully qualified";
602             }
603             for my $pkg (@packages) {
604                 if ($pkg =~ /^src:(.+)/) {
605                     $sourceversions{"$1/$version"} = 1;
606                     next unless exists $param{warnings};
607                     # check to see if this source version is even possible
608                     my @bin_versions = sourcetobinary($1,$version);
609                     if (not @bin_versions or
610                         @{$bin_versions[0]} != 3) {
611                         print {$warnings} "The source '$1' and version '$version' do not appear to match any binary packages\n";
612                     }
613                     next;
614                 }
615                 for my $arch (@archs) {
616                     my $cachearch = (defined $arch) ? $arch : '';
617                     my $cachekey = "$pkg/$cachearch/$version";
618                     if (exists($param{source_version_cache}{$cachekey})) {
619                         for my $v (@{$param{source_version_cache}{$cachekey}}) {
620                             $sourceversions{$v} = 1;
621                         }
622                         next;
623                     }
624                     elsif ($param{guess_source} and
625                            exists$param{source_version_cache}{$cachekey.'/guess'}) {
626                         for my $v (@{$param{source_version_cache}{$cachekey.'/guess'}}) {
627                             $sourceversions{$v} = 1;
628                         }
629                         next;
630                     }
631                     my @srcinfo = binary_to_source(binary => $pkg,
632                                                    version => $version,
633                                                    length($arch)?(arch    => $arch):());
634                     if (not @srcinfo) {
635                         # We don't have explicit information about the
636                         # binary-to-source mapping for this version
637                         # (yet).
638                         print {$warnings} "There is no source info for the package '$pkg' at version '$version' with architecture '$arch'\n";
639                         if ($param{guess_source}) {
640                             # Lets guess it
641                             my $pkgsrc = getpkgsrc();
642                             if (exists $pkgsrc->{$pkg}) {
643                                 @srcinfo = ([$pkgsrc->{$pkg}, $version]);
644                             } elsif (getsrcpkgs($pkg)) {
645                                 # If we're looking at a source package
646                                 # that doesn't have a binary of the
647                                 # same name, just try the same
648                                 # version.
649                                 @srcinfo = ([$pkg, $version]);
650                             } else {
651                                 next;
652                             }
653                             # store guesses in a slightly different location
654                             $param{source_version_cache}{$cachekey.'/guess'} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
655                         }
656                     }
657                     else {
658                         # only store this if we didn't have to guess it
659                         $param{source_version_cache}{$cachekey} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
660                     }
661                     $sourceversions{"$_->[0]/$_->[1]"} = 1 foreach @srcinfo;
662                 }
663             }
664         }
665     }
666     return sort keys %sourceversions;
667 }
668
669
670
671 1;