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