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 =back
 258
 259 =cut
 260
 261 our %_versions;
 262 our %_versions_time;
 263
 264 sub get_versions{
 265      my %param = validate_with(params => \@_,
 266                                 spec   => {package => {type => SCALAR,
 267                                                       },
 268                                            dist    => {type => SCALAR|ARRAYREF,
 269                                                        default => 'unstable',
 270                                                       },
 271                                            arch    => {type => SCALAR|ARRAYREF,
 272                                                        optional => 1,
 273                                                       },
 274                                            time    => {type    => BOOLEAN,
 275                                                        default => 0,
 276                                                       },
 277                                            source  => {type    => BOOLEAN,
 278                                                        default => 0,
 279                                                       },
 280                                           },
 281                                );
 282      my $versions;
 283      if ($param{time}) {
 284           return () if not defined $gVersionTimeIndex;
 285           unless (tied %_versions_time) {
 286                tie %_versions_time, 'MLDBM', $gVersionTimeIndex, O_RDONLY
 287                     or die "can't open versions index $gVersionTimeIndex: $!";
 288           }
 289           $versions = \%_versions_time;
 290      }
 291      else {
 292           return () if not defined $gVersionIndex;
 293           unless (tied %_versions) {
 294                tie %_versions, 'MLDBM', $gVersionIndex, O_RDONLY
 295                     or die "can't open versions index $gVersionIndex: $!";
 296           }
 297           $versions = \%_versions;
 298      }
 299      my %versions;
 300      for my $package (make_list($param{package})) {
 301           my $version = $versions->{$package};
 302           next unless defined $version;
 303           for my $dist (make_list($param{dist})) {
 304                for my $arch (exists $param{arch}?
 305                              make_list($param{arch}):
 306                              (keys %{$version->{$dist}})) {
 307                     next unless defined $version->{$dist}{$arch};
 308                     for my $ver (ref $version->{$dist}{$arch} ?
 309                                  keys %{$version->{$dist}{$arch}} :
 310                                  $version->{$dist}{$arch}
 311                                 ) {
 312                          my $f_ver = $ver;
 313                          if ($param{source}) {
 314                               ($f_ver) = makesourceversions($package,$arch,$ver);
 315                          }
 316                          if ($param{time}) {
 317                               $versions{$f_ver} = max($versions{$f_ver}||0,$version->{$dist}{$arch}{$ver});
 318                          }
 319                          else {
 320                               $versions{$f_ver} = 1;
 321                          }
 322                     }
 323                }
 324           }
 325      }
 326      if ($param{time}) {
 327           return %versions
 328      }
 329      return keys %versions;
 330 }
 331
 332
 333 =item makesourceversions
 334
 335      @{$cgi_var{found}} = makesourceversions($cgi_var{package},undef,@{$cgi_var{found}});
 336
 337 Canonicalize versions into source versions, which have an explicitly
 338 named source package. This is used to cope with source packages whose
 339 names have changed during their history, and with cases where source
 340 version numbers differ from binary version numbers.
 341
 342 =cut
 343
 344 our %_sourceversioncache = ();
 345 sub makesourceversions {
 346     my $pkg = shift;
 347     my $arch = shift;
 348     my %sourceversions;
 349
 350     for my $version (@_) {
 351         if ($version =~ m[/]) {
 352             # Already a source version.
 353             $sourceversions{$version} = 1;
 354         } else {
 355             my $cachearch = (defined $arch) ? $arch : '';
 356             my $cachekey = "$pkg/$cachearch/$version";
 357             if (exists($_sourceversioncache{$cachekey})) {
 358                 for my $v (@{$_sourceversioncache{$cachekey}}) {
 359                     $sourceversions{$v} = 1;
 360                 }
 361                 next;
 362             }
 363
 364             my @srcinfo = binarytosource($pkg, $version, $arch);
 365             unless (@srcinfo) {
 366                 # We don't have explicit information about the
 367                 # binary-to-source mapping for this version (yet). Since
 368                 # this is a CGI script and our output is transient, we can
 369                 # get away with just looking in the unversioned map; if it's
 370                 # wrong (as it will be when binary and source package
 371                 # versions differ), too bad.
 372                 my $pkgsrc = getpkgsrc();
 373                 if (exists $pkgsrc->{$pkg}) {
 374                     @srcinfo = ([$pkgsrc->{$pkg}, $version]);
 375                 } elsif (getsrcpkgs($pkg)) {
 376                     # If we're looking at a source package that doesn't have
 377                     # a binary of the same name, just try the same version.
 378                     @srcinfo = ([$pkg, $version]);
 379                 } else {
 380                     next;
 381                 }
 382             }
 383             $sourceversions{"$_->[0]/$_->[1]"} = 1 foreach @srcinfo;
 384             $_sourceversioncache{$cachekey} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
 385         }
 386     }
 387
 388     return sort keys %sourceversions;
 389 }
 390
 391
 392
 393 =back
 394
 395 =cut
 396
 397 1;