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 Debbugs::Config qw(:config :globals);
  16
  17 use base qw(Exporter);
  18 use vars qw($VERSION @EXPORT_OK %EXPORT_TAGS @EXPORT);
  19
  20 BEGIN {
  21     $VERSION = 1.00;
  22
  23      @EXPORT = ();
  24      %EXPORT_TAGS = (versions => [qw(getversions get_versions)],
  25                      mapping  => [qw(getpkgsrc getpkgcomponent getsrcpkgs),
  26                                   qw(binarytosource sourcetobinary makesourceversions)
  27                                  ],
  28                     );
  29      @EXPORT_OK = ();
  30      Exporter::export_ok_tags(qw(versions mapping));
  31      $EXPORT_TAGS{all} = [@EXPORT_OK];
  32 }
  33
  34 use Fcntl qw(O_RDONLY);
  35 use MLDBM qw(DB_File Storable);
  36 use Storable qw(dclone);
  37 use Params::Validate qw(validate_with :types);
  38 use Debbugs::Common qw(make_list);
  39
  40 use List::Util qw(min max);
  41
  42 $MLDBM::DumpMeth = 'portable';
  43 $MLDBM::RemoveTaint = 1;
  44
  45 =head1 NAME
  46
  47 Debbugs::Packages - debbugs binary/source package handling
  48
  49 =head1 DESCRIPTION
  50
  51 The Debbugs::Packages module provides support functions to map binary
  52 packages to their corresponding source packages and vice versa. (This makes
  53 sense for software distributions, where developers may work on a single
  54 source package which produces several binary packages for use by users; it
  55 may not make sense in other contexts.)
  56
  57 =head1 METHODS
  58
  59 =over 8
  60
  61 =item getpkgsrc
  62
  63 Returns a reference to a hash of binary package names to their corresponding
  64 source package names.
  65
  66 =cut
  67
  68 our $_pkgsrc;
  69 our $_pkgcomponent;
  70 our $_srcpkg;
  71 sub getpkgsrc {
  72     return $_pkgsrc if $_pkgsrc;
  73     return {} unless defined $Debbugs::Packages::gPackageSource;
  74     my %pkgsrc;
  75     my %pkgcomponent;
  76     my %srcpkg;
  77
  78     open(MM,"$Debbugs::Packages::gPackageSource")
  79         or die("open $Debbugs::Packages::gPackageSource: $!");
  80     while(<MM>) {
  81         next unless m/^(\S+)\s+(\S+)\s+(\S.*\S)\s*$/;
  82         my ($bin,$cmp,$src)=($1,$2,$3);
  83         $bin =~ y/A-Z/a-z/;
  84         $pkgsrc{$bin}= $src;
  85         push @{$srcpkg{$src}}, $bin;
  86         $pkgcomponent{$bin}= $cmp;
  87     }
  88     close(MM);
  89     $_pkgsrc = \%pkgsrc;
  90     $_pkgcomponent = \%pkgcomponent;
  91     $_srcpkg = \%srcpkg;
  92     return $_pkgsrc;
  93 }
  94
  95 =item getpkgcomponent
  96
  97 Returns a reference to a hash of binary package names to the component of
  98 the archive containing those binary packages (e.g. "main", "contrib",
  99 "non-free").
 100
 101 =cut
 102
 103 sub getpkgcomponent {
 104     return $_pkgcomponent if $_pkgcomponent;
 105     getpkgsrc();
 106     return $_pkgcomponent;
 107 }
 108
 109 =item getsrcpkgs
 110
 111 Returns a list of the binary packages produced by a given source package.
 112
 113 =cut
 114
 115 sub getsrcpkgs {
 116     my $src = shift;
 117     getpkgsrc() if not defined $_srcpkg;
 118     return () if not defined $src or not exists $_srcpkg->{$src};
 119     return @{$_srcpkg->{$src}};
 120 }
 121
 122 =item binarytosource
 123
 124 Returns a reference to the source package name and version pair
 125 corresponding to a given binary package name, version, and architecture.
 126
 127 If undef is passed as the architecture, returns a list of references
 128 to all possible pairs of source package names and versions for all
 129 architectures, with any duplicates removed.
 130
 131 If the binary version is not passed either, returns a list of possible
 132 source package names for all architectures at all versions, with any
 133 duplicates removed.
 134
 135 =cut
 136
 137 our %_binarytosource;
 138 sub binarytosource {
 139     my ($binname, $binver, $binarch) = @_;
 140
 141     # TODO: This gets hit a lot, especially from buggyversion() - probably
 142     # need an extra cache for speed here.
 143     return () unless defined $gBinarySourceMap;
 144
 145     if (not tied %_binarytosource) {
 146          tie %_binarytosource, MLDBM => $gBinarySourceMap, O_RDONLY or
 147               die "Unable to open $gBinarySourceMap for reading";
 148     }
 149
 150     # avoid autovivification
 151     my $binary = $_binarytosource{$binname};
 152     return () unless defined $binary;
 153     my %binary = %{$binary};
 154     if (not defined $binver) {
 155          my %uniq;
 156          for my $ver (keys %binary) {
 157               for my $ar (keys %{$binary{$ver}}) {
 158                    my $src = $binary{$ver}{$ar};
 159                    next unless defined $src;
 160                    $uniq{$src->[0]} = 1;
 161               }
 162          }
 163          return keys %uniq;
 164     }
 165     elsif (exists $binary{$binver}) {
 166          if (defined $binarch) {
 167               my $src = $binary{$binver}{$binarch};
 168               return () unless defined $src; # not on this arch
 169               # Copy the data to avoid tiedness problems.
 170               return dclone($src);
 171          } else {
 172               # Get (srcname, srcver) pairs for all architectures and
 173               # remove any duplicates. This involves some slightly tricky
 174               # multidimensional hashing; sorry. Fortunately there'll
 175               # usually only be one pair returned.
 176               my %uniq;
 177               for my $ar (keys %{$binary{$binver}}) {
 178                    my $src = $binary{$binver}{$ar};
 179                    next unless defined $src;
 180                    $uniq{$src->[0]}{$src->[1]} = 1;
 181               }
 182               my @uniq;
 183               for my $sn (sort keys %uniq) {
 184                    push @uniq, [$sn, $_] for sort keys %{$uniq{$sn}};
 185               }
 186               return @uniq;
 187          }
 188     }
 189
 190     # No $gBinarySourceMap, or it didn't have an entry for this name and
 191     # version.
 192     return ();
 193 }
 194
 195 =item sourcetobinary
 196
 197 Returns a list of references to triplets of binary package names, versions,
 198 and architectures corresponding to a given source package name and version.
 199 If the given source package name and version cannot be found in the database
 200 but the source package name is in the unversioned package-to-source map
 201 file, then a reference to a binary package name and version pair will be
 202 returned, without the architecture.
 203
 204 =cut
 205
 206 our %_sourcetobinary;
 207 sub sourcetobinary {
 208     my ($srcname, $srcver) = @_;
 209
 210     if (not tied %_sourcetobinary) {
 211          tie %_sourcetobinary, MLDBM => $gSourceBinaryMap, O_RDONLY or
 212               die "Unable top open $gSourceBinaryMap for reading";
 213     }
 214
 215
 216
 217     # avoid autovivification
 218     my $source = $_sourcetobinary{$srcname};
 219     return () unless defined $source;
 220     my %source = %{$source};
 221     if (exists $source{$srcver}) {
 222          my $bin = $source{$srcver};
 223          return () unless defined $bin;
 224          return @$bin;
 225     }
 226     # No $gSourceBinaryMap, or it didn't have an entry for this name and
 227     # version. Try $gPackageSource (unversioned) instead.
 228     my @srcpkgs = getsrcpkgs($srcname);
 229     return map [$_, $srcver], @srcpkgs;
 230 }
 231
 232 =item getversions
 233
 234 Returns versions of the package in a distribution at a specific
 235 architecture
 236
 237 =cut
 238
 239 sub getversions {
 240     my ($pkg, $dist, $arch) = @_;
 241     return get_versions(package=>$pkg,
 242                         dist => $dist,
 243                         defined $arch ? (arch => $arch):(),
 244                        );
 245 }
 246
 247
 248
 249 =head2 get_versions
 250
 251      get_versions(package=>'foopkg',
 252                   dist => 'unstable',
 253                   arch => 'i386',
 254                  );
 255
 256 Returns a list of the versions of package in the distributions and
 257 architectures listed. This routine only returns unique values.
 258
 259 =over
 260
 261 =item package -- package to return list of versions
 262
 263 =item dist -- distribution (unstable, stable, testing); can be an
 264 arrayref
 265
 266 =item arch -- architecture (i386, source, ...); can be an arrayref
 267
 268 =item time -- returns a version=>time hash at which the newest package
 269 matching this version was uploaded
 270
 271 =item source -- returns source/version instead of just versions
 272
 273 =item no_source_arch -- discards the source architecture when arch is
 274 not passed. [Used for finding the versions of binary packages only.]
 275 Defaults to 0, which does not discard the source architecture. (This
 276 may change in the future, so if you care, please code accordingly.)
 277
 278 =item return_archs -- returns a version=>[archs] hash indicating which
 279 architectures are at which versions.
 280
 281 =back
 282
 283 When called in scalar context, this function will return hashrefs or
 284 arrayrefs as appropriate, in list context, it will return paired lists
 285 or unpaired lists as appropriate.
 286
 287 =cut
 288
 289 our %_versions;
 290 our %_versions_time;
 291
 292 sub get_versions{
 293      my %param = validate_with(params => \@_,
 294                                 spec   => {package => {type => SCALAR|ARRAYREF,
 295                                                       },
 296                                            dist    => {type => SCALAR|ARRAYREF,
 297                                                        default => 'unstable',
 298                                                       },
 299                                            arch    => {type => SCALAR|ARRAYREF,
 300                                                        optional => 1,
 301                                                       },
 302                                            time    => {type    => BOOLEAN,
 303                                                        default => 0,
 304                                                       },
 305                                            source  => {type    => BOOLEAN,
 306                                                        default => 0,
 307                                                       },
 308                                            no_source_arch => {type => BOOLEAN,
 309                                                               default => 0,
 310                                                              },
 311                                            return_archs => {type => BOOLEAN,
 312                                                             default => 0,
 313                                                            },
 314                                           },
 315                                );
 316      my $versions;
 317      if ($param{time}) {
 318           return () if not defined $gVersionTimeIndex;
 319           unless (tied %_versions_time) {
 320                tie %_versions_time, 'MLDBM', $gVersionTimeIndex, O_RDONLY
 321                     or die "can't open versions index $gVersionTimeIndex: $!";
 322           }
 323           $versions = \%_versions_time;
 324      }
 325      else {
 326           return () if not defined $gVersionIndex;
 327           unless (tied %_versions) {
 328                tie %_versions, 'MLDBM', $gVersionIndex, O_RDONLY
 329                     or die "can't open versions index $gVersionIndex: $!";
 330           }
 331           $versions = \%_versions;
 332      }
 333      my %versions;
 334      for my $package (make_list($param{package})) {
 335           my $version = $versions->{$package};
 336           next unless defined $version;
 337           for my $dist (make_list($param{dist})) {
 338                for my $arch (exists $param{arch}?
 339                              make_list($param{arch}):
 340                              (grep {not $param{no_source_arch} or
 341                                          $_ ne 'source'
 342                                } keys %{$version->{$dist}})) {
 343                     next unless defined $version->{$dist}{$arch};
 344                     for my $ver (ref $version->{$dist}{$arch} ?
 345                                  keys %{$version->{$dist}{$arch}} :
 346                                  $version->{$dist}{$arch}
 347                                 ) {
 348                          my $f_ver = $ver;
 349                          if ($param{source}) {
 350                               ($f_ver) = makesourceversions($package,$arch,$ver);
 351                               next unless defined $f_ver;
 352                          }
 353                          if ($param{time}) {
 354                               $versions{$f_ver} = max($versions{$f_ver}||0,$version->{$dist}{$arch}{$ver});
 355                          }
 356                          else {
 357                               push @{$versions{$f_ver}},$arch;
 358                          }
 359                     }
 360                }
 361           }
 362      }
 363      if ($param{time} or $param{return_archs}) {
 364           return wantarray?%versions :\%versions;
 365      }
 366      return wantarray?keys %versions :[keys %versions];
 367 }
 368
 369
 370 =item makesourceversions
 371
 372      @{$cgi_var{found}} = makesourceversions($cgi_var{package},undef,@{$cgi_var{found}});
 373
 374 Canonicalize versions into source versions, which have an explicitly
 375 named source package. This is used to cope with source packages whose
 376 names have changed during their history, and with cases where source
 377 version numbers differ from binary version numbers.
 378
 379 =cut
 380
 381 our %_sourceversioncache = ();
 382 sub makesourceversions {
 383     my $pkg = shift;
 384     my $arch = shift;
 385     my %sourceversions;
 386     die "Package $pkg is multiple packages; split on , and call makesourceversions multiple times"
 387          if $pkg =~ /,/;
 388
 389     for my $version (@_) {
 390         if ($version =~ m[/]) {
 391             # Already a source version.
 392             $sourceversions{$version} = 1;
 393         } else {
 394             my $cachearch = (defined $arch) ? $arch : '';
 395             my $cachekey = "$pkg/$cachearch/$version";
 396             if (exists($_sourceversioncache{$cachekey})) {
 397                 for my $v (@{$_sourceversioncache{$cachekey}}) {
 398                     $sourceversions{$v} = 1;
 399                 }
 400                 next;
 401             }
 402
 403             my @srcinfo = binarytosource($pkg, $version, $arch);
 404             unless (@srcinfo) {
 405                 # We don't have explicit information about the
 406                 # binary-to-source mapping for this version (yet). Since
 407                 # this is a CGI script and our output is transient, we can
 408                 # get away with just looking in the unversioned map; if it's
 409                 # wrong (as it will be when binary and source package
 410                 # versions differ), too bad.
 411                 my $pkgsrc = getpkgsrc();
 412                 if (exists $pkgsrc->{$pkg}) {
 413                     @srcinfo = ([$pkgsrc->{$pkg}, $version]);
 414                 } elsif (getsrcpkgs($pkg)) {
 415                     # If we're looking at a source package that doesn't have
 416                     # a binary of the same name, just try the same version.
 417                     @srcinfo = ([$pkg, $version]);
 418                 } else {
 419                     next;
 420                 }
 421             }
 422             $sourceversions{"$_->[0]/$_->[1]"} = 1 foreach @srcinfo;
 423             $_sourceversioncache{$cachekey} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
 424         }
 425     }
 426
 427     return sort keys %sourceversions;
 428 }
 429
 430
 431
 432 =back
 433
 434 =cut
 435
 436 1;