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