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