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