]> git.donarmstrong.com Git - debbugs.git/blob - Debbugs/Packages.pm
b332525c9b76bc79e9045701c2890687d90b68dc
[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 croak("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 sub _tie_binarytosource {
173     if (not tied %_binarytosource) {
174         tie %_binarytosource, MLDBM => $config{binary_source_map}, O_RDONLY or
175             die "Unable to open $config{binary_source_map} for reading";
176     }
177 }
178 our %_sourcetobinary;
179 sub _tie_sourcetobinary {
180     if (not tied %_sourcetobinary) {
181         tie %_sourcetobinary, MLDBM => $config{source_binary_map}, O_RDONLY or
182             die "Unable to open $config{source_binary_map} for reading";
183     }
184 }
185 sub binary_to_source{
186     my %param = validate_with(params => \@_,
187                               spec   => {binary => {type => SCALAR|ARRAYREF,
188                                                     },
189                                          version => {type => SCALAR|ARRAYREF,
190                                                      optional => 1,
191                                                     },
192                                          arch    => {type => SCALAR|ARRAYREF,
193                                                      optional => 1,
194                                                     },
195                                          source_only => {default => 0,
196                                                         },
197                                          scalar_only => {default => 0,
198                                                         },
199                                          cache => {type => HASHREF,
200                                                    default => {},
201                                                   },
202                                          schema => {type => OBJECT,
203                                                     optional => 1,
204                                                    },
205                                         },
206                              );
207
208     # TODO: This gets hit a lot, especially from buggyversion() - probably
209     # need an extra cache for speed here.
210     return () unless defined $gBinarySourceMap or defined $param{schema};
211
212     if ($param{scalar_only} or not wantarray) {
213         $param{source_only} = 1;
214         $param{scalar_only} = 1;
215     }
216
217     my @source;
218     my @binaries = grep {defined $_} make_list(exists $param{binary}?$param{binary}:[]);
219     my @versions = grep {defined $_} make_list(exists $param{version}?$param{version}:[]);
220     my @archs = grep {defined $_} make_list(exists $param{arch}?$param{arch}:[]);
221     return () unless @binaries;
222
223     # any src:foo is source package foo with unspecified version
224     @source = map {/^src:(.+)$/?
225                        [$1,'']:()} @binaries;
226     @binaries = grep {$_ !~ /^src:/} @binaries;
227     if ($param{schema}) {
228         if ($param{source_only}) {
229             @source = map {$_->[0]} @source;
230             my $src_rs = $param{schema}->resultset('SrcPkg')->
231                 search_rs({'binpkg.pkg' => [@binaries],
232                            @versions?('bin_vers.ver'    => [@versions]):(),
233                            @archs?('arch.arch' => [@archs]):(),
234                           },
235                          {join => {'src_vers'=>
236                                   {'bin_vers'=> ['arch','bin_pkg']}
237                                   },
238                           distinct => 1,
239                          },
240                          );
241             push @source,
242                 map {$_->pkg} $src_rs->all;
243             if ($param{scalar_only}) {
244                 return join(',',@source);
245             }
246             return @source;
247
248         }
249         my $src_rs = $param{schema}->resultset('SrcVer')->
250             search_rs({'bin_pkg.pkg' => [@binaries],
251                        @versions?('bin_vers.ver' => [@versions]):(),
252                        @archs?('arch.arch' => [@archs]):(),
253                       },
254                      {join => ['src_pkg',
255                               {'bin_vers' => ['arch','binpkg']},
256                               ],
257                       distinct => 1,
258                      },
259                      );
260         push @source,
261             map {[$_->get_column('src_pkg.pkg'),
262                   $_->get_column('src_ver.ver'),
263                  ]} $src_rs->all;
264         if (not @source and not @versions and not @archs) {
265             $src_rs = $param{schema}->resultset('SrcPkg')->
266                 search_rs({pkg => [@binaries]},
267                          {distinct => 1},
268                          );
269             push @source,
270                 map {[$_->pkg,
271                      ]} $src_rs->all;
272         }
273         return @source;
274     }
275     my $cache_key = join("\1",
276                          join("\0",@binaries),
277                          join("\0",@versions),
278                          join("\0",@archs),
279                          join("\0",@param{qw(source_only scalar_only)}));
280     if (exists $param{cache}{$cache_key}) {
281         return $param{scalar_only} ? $param{cache}{$cache_key}[0]:
282             @{$param{cache}{$cache_key}};
283     }
284     for my $binary (@binaries) {
285         _tie_binarytosource;
286         # avoid autovivification
287         my $bin = $_binarytosource{$binary};
288         next unless defined $bin;
289         if (not @versions) {
290             for my $ver (keys %{$bin}) {
291                 for my $ar (keys %{$bin->{$ver}}) {
292                     my $src = $bin->{$ver}{$ar};
293                     next unless defined $src;
294                     push @source,[$src->[0],$src->[1]];
295                 }
296             }
297         }
298         else {
299             for my $version (@versions) {
300                 next unless exists $bin->{$version};
301                 if (exists $bin->{$version}{all}) {
302                     push @source,dclone($bin->{$version}{all});
303                     next;
304                 }
305                 my @t_archs;
306                 if (@archs) {
307                     @t_archs = @archs;
308                 }
309                 else {
310                     @t_archs = keys %{$bin->{$version}};
311                 }
312                 for my $arch (@t_archs) {
313                     push @source,dclone($bin->{$version}{$arch}) if
314                         exists $bin->{$version}{$arch};
315                 }
316             }
317         }
318     }
319
320     if (not @source and not @versions and not @archs) {
321         # ok, we haven't found any results at all. If we weren't given
322         # a specific version and architecture, then we should try
323         # really hard to figure out the right source
324
325         # if any the packages we've been given are a valid source
326         # package name, and there's no binary of the same name (we got
327         # here, so there isn't), return it.
328         _tie_sourcetobinary();
329         for my $maybe_sourcepkg (@binaries) {
330             if (exists $_sourcetobinary{$maybe_sourcepkg}) {
331                 push @source,[$maybe_sourcepkg,$_] for keys %{$_sourcetobinary{$maybe_sourcepkg}};
332             }
333         }
334         # if @source is still empty here, it's probably a non-existant
335         # source package, so don't return anything.
336     }
337
338     my @result;
339
340     if ($param{source_only}) {
341         my %uniq;
342         for my $s (@source) {
343             # we shouldn't need to do this, but do this temporarily to
344             # stop the warning.
345             next unless defined $s->[0];
346             $uniq{$s->[0]} = 1;
347         }
348         @result = sort keys %uniq;
349         if ($param{scalar_only}) {
350             @result = join(', ',@result);
351         }
352     }
353     else {
354         my %uniq;
355         for my $s (@source) {
356             $uniq{$s->[0]}{$s->[1]} = 1;
357         }
358         for my $sn (sort keys %uniq) {
359             push @result, [$sn, $_] for sort keys %{$uniq{$sn}};
360         }
361     }
362
363     # No $gBinarySourceMap, or it didn't have an entry for this name and
364     # version.
365     $param{cache}{$cache_key} = \@result;
366     return $param{scalar_only} ? $result[0] : @result;
367 }
368
369 =head2 sourcetobinary
370
371 Returns a list of references to triplets of binary package names, versions,
372 and architectures corresponding to a given source package name and version.
373 If the given source package name and version cannot be found in the database
374 but the source package name is in the unversioned package-to-source map
375 file, then a reference to a binary package name and version pair will be
376 returned, without the architecture.
377
378 =cut
379
380 sub sourcetobinary {
381     my ($srcname, $srcver) = @_;
382     _tie_sourcetobinary;
383     # avoid autovivification
384     my $source = $_sourcetobinary{$srcname};
385     return () unless defined $source;
386     if (exists $source->{$srcver}) {
387          my $bin = $source->{$srcver};
388          return () unless defined $bin;
389          return @$bin;
390     }
391     # No $gSourceBinaryMap, or it didn't have an entry for this name and
392     # version. Try $gPackageSource (unversioned) instead.
393     my @srcpkgs = getsrcpkgs($srcname);
394     return map [$_, $srcver], @srcpkgs;
395 }
396
397 =head2 getversions
398
399 Returns versions of the package in a distribution at a specific
400 architecture
401
402 =cut
403
404 sub getversions {
405     my ($pkg, $dist, $arch) = @_;
406     return get_versions(package=>$pkg,
407                         dist => $dist,
408                         defined $arch ? (arch => $arch):(),
409                        );
410 }
411
412
413
414 =head2 get_versions
415
416      get_versions(package=>'foopkg',
417                   dist => 'unstable',
418                   arch => 'i386',
419                  );
420
421 Returns a list of the versions of package in the distributions and
422 architectures listed. This routine only returns unique values.
423
424 =over
425
426 =item package -- package to return list of versions
427
428 =item dist -- distribution (unstable, stable, testing); can be an
429 arrayref
430
431 =item arch -- architecture (i386, source, ...); can be an arrayref
432
433 =item time -- returns a version=>time hash at which the newest package
434 matching this version was uploaded
435
436 =item source -- returns source/version instead of just versions
437
438 =item no_source_arch -- discards the source architecture when arch is
439 not passed. [Used for finding the versions of binary packages only.]
440 Defaults to 0, which does not discard the source architecture. (This
441 may change in the future, so if you care, please code accordingly.)
442
443 =item return_archs -- returns a version=>[archs] hash indicating which
444 architectures are at which versions.
445
446 =item largest_source_version_only -- if there is more than one source
447 version in a particular distribution, discards all versions but the
448 largest in that distribution. Defaults to 1, as this used to be the
449 way that the Debian archive worked.
450
451 =back
452
453 When called in scalar context, this function will return hashrefs or
454 arrayrefs as appropriate, in list context, it will return paired lists
455 or unpaired lists as appropriate.
456
457 =cut
458
459 our %_versions;
460 our %_versions_time;
461
462 sub get_versions{
463      my %param = validate_with(params => \@_,
464                                 spec   => {package => {type => SCALAR|ARRAYREF,
465                                                       },
466                                            dist    => {type => SCALAR|ARRAYREF,
467                                                        default => 'unstable',
468                                                       },
469                                            arch    => {type => SCALAR|ARRAYREF,
470                                                        optional => 1,
471                                                       },
472                                            time    => {type    => BOOLEAN,
473                                                        default => 0,
474                                                       },
475                                            source  => {type    => BOOLEAN,
476                                                        default => 0,
477                                                       },
478                                            no_source_arch => {type => BOOLEAN,
479                                                               default => 0,
480                                                              },
481                                            return_archs => {type => BOOLEAN,
482                                                             default => 0,
483                                                            },
484                                            largest_source_version_only => {type => BOOLEAN,
485                                                                        default => 1,
486                                                                           },
487                                           },
488                                );
489      my $versions;
490      if ($param{time}) {
491           return () if not defined $gVersionTimeIndex;
492           unless (tied %_versions_time) {
493                tie %_versions_time, 'MLDBM', $gVersionTimeIndex, O_RDONLY
494                     or die "can't open versions index $gVersionTimeIndex: $!";
495           }
496           $versions = \%_versions_time;
497      }
498      else {
499           return () if not defined $gVersionIndex;
500           unless (tied %_versions) {
501                tie %_versions, 'MLDBM', $gVersionIndex, O_RDONLY
502                     or die "can't open versions index $gVersionIndex: $!";
503           }
504           $versions = \%_versions;
505      }
506      my %versions;
507      for my $package (make_list($param{package})) {
508           my $source_only = 0;
509           if ($package =~ s/^src://) {
510                $source_only = 1;
511           }
512           my $version = $versions->{$package};
513           next unless defined $version;
514           for my $dist (make_list($param{dist})) {
515                for my $arch (exists $param{arch}?
516                              make_list($param{arch}):
517                              (grep {not $param{no_source_arch} or
518                                         $_ ne 'source'
519                                     } $source_only?'source':keys %{$version->{$dist}})) {
520                     next unless defined $version->{$dist}{$arch};
521                     my @vers = ref $version->{$dist}{$arch} eq 'HASH' ?
522                         keys %{$version->{$dist}{$arch}} :
523                             make_list($version->{$dist}{$arch});
524                     if ($param{largest_source_version_only} and
525                         $arch eq 'source' and @vers > 1) {
526                         # order the versions, then pick the biggest version number
527                         @vers = sort_versions(@vers);
528                         @vers = $vers[-1];
529                     }
530                     for my $ver (@vers) {
531                          my $f_ver = $ver;
532                          if ($param{source}) {
533                               ($f_ver) = make_source_versions(package => $package,
534                                                               arch => $arch,
535                                                               versions => $ver);
536                               next unless defined $f_ver;
537                          }
538                          if ($param{time}) {
539                               $versions{$f_ver} = max($versions{$f_ver}||0,$version->{$dist}{$arch}{$ver});
540                          }
541                          else {
542                               push @{$versions{$f_ver}},$arch;
543                          }
544                     }
545                }
546           }
547      }
548      if ($param{time} or $param{return_archs}) {
549           return wantarray?%versions :\%versions;
550      }
551      return wantarray?keys %versions :[keys %versions];
552 }
553
554
555 =head2 makesourceversions
556
557      @{$cgi_var{found}} = makesourceversions($cgi_var{package},undef,@{$cgi_var{found}});
558
559 Canonicalize versions into source versions, which have an explicitly
560 named source package. This is used to cope with source packages whose
561 names have changed during their history, and with cases where source
562 version numbers differ from binary version numbers.
563
564 =cut
565
566 our %_sourceversioncache = ();
567 sub makesourceversions {
568     my ($package,$arch,@versions) = @_;
569     die "Package $package is multiple packages; split on , and call makesourceversions multiple times"
570          if $package =~ /,/;
571     return make_source_versions(package => $package,
572                                 (defined $arch)?(arch => $arch):(),
573                                 versions => \@versions
574                                );
575 }
576
577 =head2 make_source_versions
578
579      make_source_versions(package => 'foo',
580                           arch    => 'source',
581                           versions => '0.1.1',
582                           guess_source => 1,
583                           warnings => \$warnings,
584                          );
585
586 An extended version of makesourceversions (which calls this function
587 internally) that allows for multiple packages, architectures, and
588 outputs warnings and debugging information to provided SCALARREFs or
589 HANDLEs.
590
591 The guess_source option determines whether the source package is
592 guessed at if there is no obviously correct package. Things that use
593 this function for non-transient output should set this to false,
594 things that use it for transient output can set this to true.
595 Currently it defaults to true, but that is not a sane option.
596
597
598 =cut
599
600 sub make_source_versions {
601     my %param = validate_with(params => \@_,
602                               spec   => {package => {type => SCALAR|ARRAYREF,
603                                                     },
604                                          arch    => {type => SCALAR|ARRAYREF|UNDEF,
605                                                      default => ''
606                                                     },
607                                          versions => {type => SCALAR|ARRAYREF,
608                                                       default => [],
609                                                      },
610                                          guess_source => {type => BOOLEAN,
611                                                           default => 1,
612                                                          },
613                                          source_version_cache => {type => HASHREF,
614                                                                   optional => 1,
615                                                                  },
616                                          debug    => {type => SCALARREF|HANDLE,
617                                                       optional => 1,
618                                                      },
619                                          warnings => {type => SCALARREF|HANDLE,
620                                                       optional => 1,
621                                                      },
622                                         },
623                              );
624     my ($warnings) = globify_scalar(exists $param{warnings}?$param{warnings}:undef);
625
626     my @packages = grep {defined $_ and length $_ } make_list($param{package});
627     my @archs    = grep {defined $_ } make_list ($param{arch});
628     if (not @archs) {
629         push @archs, '';
630     }
631     if (not exists $param{source_version_cache}) {
632         $param{source_version_cache} = \%_sourceversioncache;
633     }
634     if (grep {/,/} make_list($param{package})) {
635         croak "Package names contain ,; split on /,/ and call make_source_versions with an arrayref of packages"
636     }
637     my %sourceversions;
638     for my $version (make_list($param{versions})) {
639         if ($version =~ m{(.+)/([^/]+)$}) {
640             # Already a source version.
641             $sourceversions{$version} = 1;
642             next unless exists $param{warnings};
643             # check to see if this source version is even possible
644             my @bin_versions = sourcetobinary($1,$2);
645             if (not @bin_versions or
646                 @{$bin_versions[0]} != 3) {
647                 print {$warnings} "The source $1 and version $2 do not appear to match any binary packages\n";
648             }
649         } else {
650             if (not @packages) {
651                 croak "You must provide at least one package if the versions are not fully qualified";
652             }
653             for my $pkg (@packages) {
654                 if ($pkg =~ /^src:(.+)/) {
655                     $sourceversions{"$1/$version"} = 1;
656                     next unless exists $param{warnings};
657                     # check to see if this source version is even possible
658                     my @bin_versions = sourcetobinary($1,$version);
659                     if (not @bin_versions or
660                         @{$bin_versions[0]} != 3) {
661                         print {$warnings} "The source '$1' and version '$version' do not appear to match any binary packages\n";
662                     }
663                     next;
664                 }
665                 for my $arch (@archs) {
666                     my $cachearch = (defined $arch) ? $arch : '';
667                     my $cachekey = "$pkg/$cachearch/$version";
668                     if (exists($param{source_version_cache}{$cachekey})) {
669                         for my $v (@{$param{source_version_cache}{$cachekey}}) {
670                             $sourceversions{$v} = 1;
671                         }
672                         next;
673                     }
674                     elsif ($param{guess_source} and
675                            exists$param{source_version_cache}{$cachekey.'/guess'}) {
676                         for my $v (@{$param{source_version_cache}{$cachekey.'/guess'}}) {
677                             $sourceversions{$v} = 1;
678                         }
679                         next;
680                     }
681                     my @srcinfo = binary_to_source(binary => $pkg,
682                                                    version => $version,
683                                                    length($arch)?(arch    => $arch):());
684                     if (not @srcinfo) {
685                         # We don't have explicit information about the
686                         # binary-to-source mapping for this version
687                         # (yet).
688                         print {$warnings} "There is no source info for the package '$pkg' at version '$version' with architecture '$arch'\n";
689                         if ($param{guess_source}) {
690                             # Lets guess it
691                             my $pkgsrc = getpkgsrc();
692                             if (exists $pkgsrc->{$pkg}) {
693                                 @srcinfo = ([$pkgsrc->{$pkg}, $version]);
694                             } elsif (getsrcpkgs($pkg)) {
695                                 # If we're looking at a source package
696                                 # that doesn't have a binary of the
697                                 # same name, just try the same
698                                 # version.
699                                 @srcinfo = ([$pkg, $version]);
700                             } else {
701                                 next;
702                             }
703                             # store guesses in a slightly different location
704                             $param{source_version_cache}{$cachekey.'/guess'} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
705                         }
706                     }
707                     else {
708                         # only store this if we didn't have to guess it
709                         $param{source_version_cache}{$cachekey} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
710                     }
711                     $sourceversions{"$_->[0]/$_->[1]"} = 1 foreach @srcinfo;
712                 }
713             }
714         }
715     }
716     return sort keys %sourceversions;
717 }
718
719
720
721 1;