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. If
 126 undef is passed as the architecture, returns a list of references to all
 127 possible pairs of source package names and versions for all architectures,
 128 with any duplicates removed.
 129
 130 =cut
 131
 132 our %_binarytosource;
 133 sub binarytosource {
 134     my ($binname, $binver, $binarch) = @_;
 135
 136     # TODO: This gets hit a lot, especially from buggyversion() - probably
 137     # need an extra cache for speed here.
 138     return () unless defined $gBinarySourceMap;
 139
 140     if (not tied %_binarytosource) {
 141          tie %_binarytosource, MLDBM => $gBinarySourceMap, O_RDONLY or
 142               die "Unable to open $gBinarySourceMap for reading";
 143     }
 144
 145     # avoid autovivification
 146     my $binary = $_binarytosource{$binname};
 147     return () unless defined $binary;
 148     my %binary = %{$binary};
 149     if (exists $binary{$binver}) {
 150          if (defined $binarch) {
 151               my $src = $binary{$binver}{$binarch};
 152               return () unless defined $src; # not on this arch
 153               # Copy the data to avoid tiedness problems.
 154               return dclone($src);
 155          } else {
 156               # Get (srcname, srcver) pairs for all architectures and
 157               # remove any duplicates. This involves some slightly tricky
 158               # multidimensional hashing; sorry. Fortunately there'll
 159               # usually only be one pair returned.
 160               my %uniq;
 161               for my $ar (keys %{$binary{$binver}}) {
 162                    my $src = $binary{$binver}{$ar};
 163                    next unless defined $src;
 164                    $uniq{$src->[0]}{$src->[1]} = 1;
 165               }
 166               my @uniq;
 167               for my $sn (sort keys %uniq) {
 168                    push @uniq, [$sn, $_] for sort keys %{$uniq{$sn}};
 169               }
 170               return @uniq;
 171          }
 172     }
 173
 174     # No $gBinarySourceMap, or it didn't have an entry for this name and
 175     # version.
 176     return ();
 177 }
 178
 179 =item sourcetobinary
 180
 181 Returns a list of references to triplets of binary package names, versions,
 182 and architectures corresponding to a given source package name and version.
 183 If the given source package name and version cannot be found in the database
 184 but the source package name is in the unversioned package-to-source map
 185 file, then a reference to a binary package name and version pair will be
 186 returned, without the architecture.
 187
 188 =cut
 189
 190 our %_sourcetobinary;
 191 sub sourcetobinary {
 192     my ($srcname, $srcver) = @_;
 193
 194     if (not tied %_sourcetobinary) {
 195          tie %_sourcetobinary, MLDBM => $gSourceBinaryMap, O_RDONLY or
 196               die "Unable top open $gSourceBinaryMap for reading";
 197     }
 198
 199
 200
 201     # avoid autovivification
 202     my $source = $_sourcetobinary{$srcname};
 203     return () unless defined $source;
 204     my %source = %{$source};
 205     if (exists $source{$srcver}) {
 206          my $bin = $source{$srcver};
 207          return () unless defined $bin;
 208          return @$bin;
 209     }
 210     # No $gSourceBinaryMap, or it didn't have an entry for this name and
 211     # version. Try $gPackageSource (unversioned) instead.
 212     my @srcpkgs = getsrcpkgs($srcname);
 213     return map [$_, $srcver], @srcpkgs;
 214 }
 215
 216 =item getversions
 217
 218 Returns versions of the package in a distribution at a specific
 219 architecture
 220
 221 =cut
 222
 223 sub getversions {
 224     my ($pkg, $dist, $arch) = @_;
 225     return get_versions(package=>$pkg,
 226                         dist => $dist,
 227                         defined $arch ? (arch => $arch):(),
 228                        );
 229 }
 230
 231
 232
 233 =head2 get_versions
 234
 235      get_version(package=>'foopkg',
 236                  dist => 'unstable',
 237                  arch => 'i386',
 238                 );
 239
 240 Returns a list of the versions of package in the distributions and
 241 architectures listed. This routine only returns unique values.
 242
 243 =over
 244
 245 =item package -- package to return list of versions
 246
 247 =item dist -- distribution (unstable, stable, testing); can be an
 248 arrayref
 249
 250 =item arch -- architecture (i386, source, ...); can be an arrayref
 251
 252 =item time -- returns a version=>time hash at which the newest package
 253 matching this version was uploaded
 254
 255 =item source -- returns source/version instead of just versions
 256
 257 =item no_source_arch -- discards the source architecture when arch is
 258 not passed. [Used for finding the versions of binary packages only.]
 259 Defaults to 0, which does not discard the source architecture. (This
 260 may change in the future, so if you care, please code accordingly.)
 261
 262 =back
 263
 264 =cut
 265
 266 our %_versions;
 267 our %_versions_time;
 268
 269 sub get_versions{
 270      my %param = validate_with(params => \@_,
 271                                 spec   => {package => {type => SCALAR|ARRAYREF,
 272                                                       },
 273                                            dist    => {type => SCALAR|ARRAYREF,
 274                                                        default => 'unstable',
 275                                                       },
 276                                            arch    => {type => SCALAR|ARRAYREF,
 277                                                        optional => 1,
 278                                                       },
 279                                            time    => {type    => BOOLEAN,
 280                                                        default => 0,
 281                                                       },
 282                                            source  => {type    => BOOLEAN,
 283                                                        default => 0,
 284                                                       },
 285                                            no_source_arch => {type => BOOLEAN,
 286                                                               default => 0,
 287                                                              },
 288                                           },
 289                                );
 290      my $versions;
 291      if ($param{time}) {
 292           return () if not defined $gVersionTimeIndex;
 293           unless (tied %_versions_time) {
 294                tie %_versions_time, 'MLDBM', $gVersionTimeIndex, O_RDONLY
 295                     or die "can't open versions index $gVersionTimeIndex: $!";
 296           }
 297           $versions = \%_versions_time;
 298      }
 299      else {
 300           return () if not defined $gVersionIndex;
 301           unless (tied %_versions) {
 302                tie %_versions, 'MLDBM', $gVersionIndex, O_RDONLY
 303                     or die "can't open versions index $gVersionIndex: $!";
 304           }
 305           $versions = \%_versions;
 306      }
 307      my %versions;
 308      for my $package (make_list($param{package})) {
 309           my $version = $versions->{$package};
 310           next unless defined $version;
 311           for my $dist (make_list($param{dist})) {
 312                for my $arch (exists $param{arch}?
 313                              make_list($param{arch}):
 314                              (grep {not $param{no_source_arch} or
 315                                          $_ ne 'source'
 316                                } keys %{$version->{$dist}})) {
 317                     next unless defined $version->{$dist}{$arch};
 318                     for my $ver (ref $version->{$dist}{$arch} ?
 319                                  keys %{$version->{$dist}{$arch}} :
 320                                  $version->{$dist}{$arch}
 321                                 ) {
 322                          my $f_ver = $ver;
 323                          if ($param{source}) {
 324                               ($f_ver) = makesourceversions($package,$arch,$ver);
 325                               next unless defined $f_ver;
 326                          }
 327                          if ($param{time}) {
 328                               $versions{$f_ver} = max($versions{$f_ver}||0,$version->{$dist}{$arch}{$ver});
 329                          }
 330                          else {
 331                               $versions{$f_ver} = 1;
 332                          }
 333                     }
 334                }
 335           }
 336      }
 337      if ($param{time}) {
 338           return %versions
 339      }
 340      return keys %versions;
 341 }
 342
 343
 344 =item makesourceversions
 345
 346      @{$cgi_var{found}} = makesourceversions($cgi_var{package},undef,@{$cgi_var{found}});
 347
 348 Canonicalize versions into source versions, which have an explicitly
 349 named source package. This is used to cope with source packages whose
 350 names have changed during their history, and with cases where source
 351 version numbers differ from binary version numbers.
 352
 353 =cut
 354
 355 our %_sourceversioncache = ();
 356 sub makesourceversions {
 357     my $pkg = shift;
 358     my $arch = shift;
 359     my %sourceversions;
 360     die "Package $pkg is multiple packages; split on , and call makesourceversions multiple times"
 361          if $pkg =~ /,/;
 362
 363     for my $version (@_) {
 364         if ($version =~ m[/]) {
 365             # Already a source version.
 366             $sourceversions{$version} = 1;
 367         } else {
 368             my $cachearch = (defined $arch) ? $arch : '';
 369             my $cachekey = "$pkg/$cachearch/$version";
 370             if (exists($_sourceversioncache{$cachekey})) {
 371                 for my $v (@{$_sourceversioncache{$cachekey}}) {
 372                     $sourceversions{$v} = 1;
 373                 }
 374                 next;
 375             }
 376
 377             my @srcinfo = binarytosource($pkg, $version, $arch);
 378             unless (@srcinfo) {
 379                 # We don't have explicit information about the
 380                 # binary-to-source mapping for this version (yet). Since
 381                 # this is a CGI script and our output is transient, we can
 382                 # get away with just looking in the unversioned map; if it's
 383                 # wrong (as it will be when binary and source package
 384                 # versions differ), too bad.
 385                 my $pkgsrc = getpkgsrc();
 386                 if (exists $pkgsrc->{$pkg}) {
 387                     @srcinfo = ([$pkgsrc->{$pkg}, $version]);
 388                 } elsif (getsrcpkgs($pkg)) {
 389                     # If we're looking at a source package that doesn't have
 390                     # a binary of the same name, just try the same version.
 391                     @srcinfo = ([$pkg, $version]);
 392                 } else {
 393                     next;
 394                 }
 395             }
 396             $sourceversions{"$_->[0]/$_->[1]"} = 1 foreach @srcinfo;
 397             $_sourceversioncache{$cachekey} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
 398         }
 399     }
 400
 401     return sort keys %sourceversions;
 402 }
 403
 404
 405
 406 =back
 407
 408 =cut
 409
 410 1;