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 base qw(Exporter);
  16 use vars qw($VERSION @EXPORT_OK %EXPORT_TAGS @EXPORT);
  17
  18 use Carp;
  19
  20 use Debbugs::Config qw(:config :globals);
  21
  22 BEGIN {
  23     $VERSION = 1.00;
  24
  25      @EXPORT = ();
  26      %EXPORT_TAGS = (versions => [qw(getversions get_versions make_source_versions)],
  27                      mapping  => [qw(getpkgsrc getpkgcomponent getsrcpkgs),
  28                                   qw(binarytosource sourcetobinary makesourceversions)
  29                                  ],
  30                     );
  31      @EXPORT_OK = ();
  32      Exporter::export_ok_tags(qw(versions mapping));
  33      $EXPORT_TAGS{all} = [@EXPORT_OK];
  34 }
  35
  36 use Fcntl qw(O_RDONLY);
  37 use MLDBM qw(DB_File Storable);
  38 use Storable qw(dclone);
  39 use Params::Validate qw(validate_with :types);
  40 use Debbugs::Common qw(make_list globify_scalar);
  41
  42 use List::Util qw(min max);
  43
  44 use IO::File;
  45
  46 $MLDBM::DumpMeth = 'portable';
  47 $MLDBM::RemoveTaint = 1;
  48
  49 =head1 NAME
  50
  51 Debbugs::Packages - debbugs binary/source package handling
  52
  53 =head1 DESCRIPTION
  54
  55 The Debbugs::Packages module provides support functions to map binary
  56 packages to their corresponding source packages and vice versa. (This makes
  57 sense for software distributions, where developers may work on a single
  58 source package which produces several binary packages for use by users; it
  59 may not make sense in other contexts.)
  60
  61 =head1 METHODS
  62
  63 =head2 getpkgsrc
  64
  65 Returns a reference to a hash of binary package names to their corresponding
  66 source package names.
  67
  68 =cut
  69
  70 our $_pkgsrc;
  71 our $_pkgcomponent;
  72 our $_srcpkg;
  73 sub getpkgsrc {
  74     return $_pkgsrc if $_pkgsrc;
  75     return {} unless defined $Debbugs::Packages::gPackageSource;
  76     my %pkgsrc;
  77     my %pkgcomponent;
  78     my %srcpkg;
  79
  80     my $fh = IO::File->new($config{package_source},'r')
  81         or die("Unable to open $config{package_source} for reading: $!");
  82     while(<$fh>) {
  83         next unless m/^(\S+)\s+(\S+)\s+(\S.*\S)\s*$/;
  84         my ($bin,$cmp,$src)=($1,$2,$3);
  85         $bin = lc($bin);
  86         $pkgsrc{$bin}= $src;
  87         push @{$srcpkg{$src}}, $bin;
  88         $pkgcomponent{$bin}= $cmp;
  89     }
  90     close($fh);
  91     $_pkgsrc = \%pkgsrc;
  92     $_pkgcomponent = \%pkgcomponent;
  93     $_srcpkg = \%srcpkg;
  94     return $_pkgsrc;
  95 }
  96
  97 =head2 getpkgcomponent
  98
  99 Returns a reference to a hash of binary package names to the component of
 100 the archive containing those binary packages (e.g. "main", "contrib",
 101 "non-free").
 102
 103 =cut
 104
 105 sub getpkgcomponent {
 106     return $_pkgcomponent if $_pkgcomponent;
 107     getpkgsrc();
 108     return $_pkgcomponent;
 109 }
 110
 111 =head2 getsrcpkgs
 112
 113 Returns a list of the binary packages produced by a given source package.
 114
 115 =cut
 116
 117 sub getsrcpkgs {
 118     my $src = shift;
 119     getpkgsrc() if not defined $_srcpkg;
 120     return () if not defined $src or not exists $_srcpkg->{$src};
 121     return @{$_srcpkg->{$src}};
 122 }
 123
 124 =head2 binarytosource
 125
 126 Returns a reference to the source package name and version pair
 127 corresponding to a given binary package name, version, and architecture.
 128
 129 If undef is passed as the architecture, returns a list of references
 130 to all possible pairs of source package names and versions for all
 131 architectures, with any duplicates removed.
 132
 133 If the binary version is not passed either, returns a list of possible
 134 source package names for all architectures at all versions, with any
 135 duplicates removed.
 136
 137 =cut
 138
 139 our %_binarytosource;
 140 sub binarytosource {
 141     my ($binname, $binver, $binarch) = @_;
 142
 143     # TODO: This gets hit a lot, especially from buggyversion() - probably
 144     # need an extra cache for speed here.
 145     return () unless defined $gBinarySourceMap;
 146
 147     if ($binname =~ m/^src:(.+)$/) {
 148         return $1;
 149     }
 150     if (not tied %_binarytosource) {
 151          tie %_binarytosource, MLDBM => $gBinarySourceMap, O_RDONLY or
 152               die "Unable to open $gBinarySourceMap for reading";
 153     }
 154
 155     # avoid autovivification
 156     my $binary = $_binarytosource{$binname};
 157     return () unless defined $binary;
 158     my %binary = %{$binary};
 159     if (not defined $binver) {
 160          my %uniq;
 161          for my $ver (keys %binary) {
 162               for my $ar (keys %{$binary{$ver}}) {
 163                    my $src = $binary{$ver}{$ar};
 164                    next unless defined $src;
 165                    $uniq{$src->[0]} = 1;
 166               }
 167          }
 168          return keys %uniq;
 169     }
 170     elsif (exists $binary{$binver}) {
 171          if (defined $binarch) {
 172               my $src = $binary{$binver}{$binarch};
 173               if (not defined $src and exists $binary{$binver}{all}) {
 174                   $src = $binary{$binver}{all};
 175               }
 176               return () unless defined $src; # not on this arch
 177               # Copy the data to avoid tiedness problems.
 178               return dclone($src);
 179          } else {
 180               # Get (srcname, srcver) pairs for all architectures and
 181               # remove any duplicates. This involves some slightly tricky
 182               # multidimensional hashing; sorry. Fortunately there'll
 183               # usually only be one pair returned.
 184               my %uniq;
 185               for my $ar (keys %{$binary{$binver}}) {
 186                    my $src = $binary{$binver}{$ar};
 187                    next unless defined $src;
 188                    $uniq{$src->[0]}{$src->[1]} = 1;
 189               }
 190               my @uniq;
 191               for my $sn (sort keys %uniq) {
 192                    push @uniq, [$sn, $_] for sort keys %{$uniq{$sn}};
 193               }
 194               return @uniq;
 195          }
 196     }
 197
 198     # No $gBinarySourceMap, or it didn't have an entry for this name and
 199     # version.
 200     return ();
 201 }
 202
 203 =head2 sourcetobinary
 204
 205 Returns a list of references to triplets of binary package names, versions,
 206 and architectures corresponding to a given source package name and version.
 207 If the given source package name and version cannot be found in the database
 208 but the source package name is in the unversioned package-to-source map
 209 file, then a reference to a binary package name and version pair will be
 210 returned, without the architecture.
 211
 212 =cut
 213
 214 our %_sourcetobinary;
 215 sub sourcetobinary {
 216     my ($srcname, $srcver) = @_;
 217
 218     if (not tied %_sourcetobinary) {
 219          tie %_sourcetobinary, MLDBM => $gSourceBinaryMap, O_RDONLY or
 220               die "Unable top open $gSourceBinaryMap for reading";
 221     }
 222
 223
 224
 225     # avoid autovivification
 226     my $source = $_sourcetobinary{$srcname};
 227     return () unless defined $source;
 228     if (exists $source->{$srcver}) {
 229          my $bin = $source->{$srcver};
 230          return () unless defined $bin;
 231          return @$bin;
 232     }
 233     # No $gSourceBinaryMap, or it didn't have an entry for this name and
 234     # version. Try $gPackageSource (unversioned) instead.
 235     my @srcpkgs = getsrcpkgs($srcname);
 236     return map [$_, $srcver], @srcpkgs;
 237 }
 238
 239 =head2 getversions
 240
 241 Returns versions of the package in a distribution at a specific
 242 architecture
 243
 244 =cut
 245
 246 sub getversions {
 247     my ($pkg, $dist, $arch) = @_;
 248     return get_versions(package=>$pkg,
 249                         dist => $dist,
 250                         defined $arch ? (arch => $arch):(),
 251                        );
 252 }
 253
 254
 255
 256 =head2 get_versions
 257
 258      get_versions(package=>'foopkg',
 259                   dist => 'unstable',
 260                   arch => 'i386',
 261                  );
 262
 263 Returns a list of the versions of package in the distributions and
 264 architectures listed. This routine only returns unique values.
 265
 266 =over
 267
 268 =item package -- package to return list of versions
 269
 270 =item dist -- distribution (unstable, stable, testing); can be an
 271 arrayref
 272
 273 =item arch -- architecture (i386, source, ...); can be an arrayref
 274
 275 =item time -- returns a version=>time hash at which the newest package
 276 matching this version was uploaded
 277
 278 =item source -- returns source/version instead of just versions
 279
 280 =item no_source_arch -- discards the source architecture when arch is
 281 not passed. [Used for finding the versions of binary packages only.]
 282 Defaults to 0, which does not discard the source architecture. (This
 283 may change in the future, so if you care, please code accordingly.)
 284
 285 =item return_archs -- returns a version=>[archs] hash indicating which
 286 architectures are at which versions.
 287
 288 =back
 289
 290 When called in scalar context, this function will return hashrefs or
 291 arrayrefs as appropriate, in list context, it will return paired lists
 292 or unpaired lists as appropriate.
 293
 294 =cut
 295
 296 our %_versions;
 297 our %_versions_time;
 298
 299 sub get_versions{
 300      my %param = validate_with(params => \@_,
 301                                 spec   => {package => {type => SCALAR|ARRAYREF,
 302                                                       },
 303                                            dist    => {type => SCALAR|ARRAYREF,
 304                                                        default => 'unstable',
 305                                                       },
 306                                            arch    => {type => SCALAR|ARRAYREF,
 307                                                        optional => 1,
 308                                                       },
 309                                            time    => {type    => BOOLEAN,
 310                                                        default => 0,
 311                                                       },
 312                                            source  => {type    => BOOLEAN,
 313                                                        default => 0,
 314                                                       },
 315                                            no_source_arch => {type => BOOLEAN,
 316                                                               default => 0,
 317                                                              },
 318                                            return_archs => {type => BOOLEAN,
 319                                                             default => 0,
 320                                                            },
 321                                           },
 322                                );
 323      my $versions;
 324      if ($param{time}) {
 325           return () if not defined $gVersionTimeIndex;
 326           unless (tied %_versions_time) {
 327                tie %_versions_time, 'MLDBM', $gVersionTimeIndex, O_RDONLY
 328                     or die "can't open versions index $gVersionTimeIndex: $!";
 329           }
 330           $versions = \%_versions_time;
 331      }
 332      else {
 333           return () if not defined $gVersionIndex;
 334           unless (tied %_versions) {
 335                tie %_versions, 'MLDBM', $gVersionIndex, O_RDONLY
 336                     or die "can't open versions index $gVersionIndex: $!";
 337           }
 338           $versions = \%_versions;
 339      }
 340      my %versions;
 341      for my $package (make_list($param{package})) {
 342           my $version = $versions->{$package};
 343           next unless defined $version;
 344           for my $dist (make_list($param{dist})) {
 345                for my $arch (exists $param{arch}?
 346                              make_list($param{arch}):
 347                              (grep {not $param{no_source_arch} or
 348                                         $_ ne 'source'
 349                                     } keys %{$version->{$dist}})) {
 350                     next unless defined $version->{$dist}{$arch};
 351                     for my $ver (ref $version->{$dist}{$arch} ?
 352                                  keys %{$version->{$dist}{$arch}} :
 353                                  $version->{$dist}{$arch}
 354                                 ) {
 355                          my $f_ver = $ver;
 356                          if ($param{source}) {
 357                               ($f_ver) = make_source_versions(package => $package,
 358                                                               arch => $arch,
 359                                                               versions => $ver);
 360                               next unless defined $f_ver;
 361                          }
 362                          if ($param{time}) {
 363                               $versions{$f_ver} = max($versions{$f_ver}||0,$version->{$dist}{$arch}{$ver});
 364                          }
 365                          else {
 366                               push @{$versions{$f_ver}},$arch;
 367                          }
 368                     }
 369                }
 370           }
 371      }
 372      if ($param{time} or $param{return_archs}) {
 373           return wantarray?%versions :\%versions;
 374      }
 375      return wantarray?keys %versions :[keys %versions];
 376 }
 377
 378
 379 =head2 makesourceversions
 380
 381      @{$cgi_var{found}} = makesourceversions($cgi_var{package},undef,@{$cgi_var{found}});
 382
 383 Canonicalize versions into source versions, which have an explicitly
 384 named source package. This is used to cope with source packages whose
 385 names have changed during their history, and with cases where source
 386 version numbers differ from binary version numbers.
 387
 388 =cut
 389
 390 our %_sourceversioncache = ();
 391 sub makesourceversions {
 392     my ($package,$arch,@versions) = @_;
 393     die "Package $package is multiple packages; split on , and call makesourceversions multiple times"
 394          if $package =~ /,/;
 395     return make_source_versions(package => $package,
 396                                 (defined $arch)?(arch => $arch):(),
 397                                 versions => \@versions
 398                                );
 399 }
 400
 401 =head2 make_source_versions
 402
 403      make_source_versions(package => 'foo',
 404                           arch    => 'source',
 405                           versions => '0.1.1',
 406                           guess_source => 1,
 407                           debug    => \$debug,
 408                           warnings => \$warnings,
 409                          );
 410
 411 An extended version of makesourceversions (which calls this function
 412 internally) that allows for multiple packages, architectures, and
 413 outputs warnings and debugging information to provided SCALARREFs or
 414 HANDLEs.
 415
 416 The guess_source option determines whether the source package is
 417 guessed at if there is no obviously correct package. Things that use
 418 this function for non-transient output should set this to false,
 419 things that use it for transient output can set this to true.
 420 Currently it defaults to true, but that is not a sane option.
 421
 422
 423 =cut
 424
 425 sub make_source_versions {
 426     my %param = validate_with(params => \@_,
 427                               spec   => {package => {type => SCALAR|ARRAYREF,
 428                                                     },
 429                                          arch    => {type => SCALAR|ARRAYREF|UNDEF,
 430                                                      default => ''
 431                                                     },
 432                                          versions => {type => SCALAR|ARRAYREF,
 433                                                       default => [],
 434                                                      },
 435                                          guess_source => {type => BOOLEAN,
 436                                                           default => 1,
 437                                                          },
 438                                          source_version_cache => {type => HASHREF,
 439                                                                   optional => 1,
 440                                                                  },
 441                                          debug    => {type => SCALARREF|HANDLE,
 442                                                       optional => 1,
 443                                                      },
 444                                          warnings => {type => SCALARREF|HANDLE,
 445                                                       optional => 1,
 446                                                      },
 447                                         },
 448                              );
 449     my ($warnings) = globify_scalar(exists $param{warnings}?$param{warnings}:undef);
 450     my ($debug)    = globify_scalar(exists $param{debug}   ?$param{debug}   :undef);
 451
 452     my @packages = grep {defined $_ and length $_ } make_list($param{package});
 453     my @archs    = grep {defined $_ } make_list ($param{arch});
 454     if (not @archs) {
 455         push @archs, '';
 456     }
 457     if (not exists $param{source_version_cache}) {
 458         $param{source_version_cache} = \%_sourceversioncache;
 459     }
 460     if (grep {/,/} make_list($param{package})) {
 461         croak "Package names contain ,; split on /,/ and call make_source_versions with an arrayref of packages"
 462     }
 463     my %sourceversions;
 464     for my $version (make_list($param{versions})) {
 465         if ($version =~ m{(.+)/([^/]+)$}) {
 466             # check to see if this source version is even possible
 467             my @bin_versions = sourcetobinary($1,$2);
 468             if (not @bin_versions or
 469                 @{$bin_versions[0]} != 3) {
 470                 print {$warnings} "The source $1 and version $2 do not appear to match any binary packages\n";
 471             }
 472             # Already a source version.
 473             $sourceversions{$version} = 1;
 474         } else {
 475             if (not @packages) {
 476                 croak "You must provide at least one package if the versions are not fully qualified";
 477             }
 478             for my $pkg (@packages) {
 479                 for my $arch (@archs) {
 480                     my $cachearch = (defined $arch) ? $arch : '';
 481                     my $cachekey = "$pkg/$cachearch/$version";
 482                     if (exists($param{source_version_cache}{$cachekey})) {
 483                         for my $v (@{$param{source_version_cache}{$cachekey}}) {
 484                             $sourceversions{$v} = 1;
 485                         }
 486                         next;
 487                     }
 488                     elsif ($param{guess_source} and
 489                            exists$param{source_version_cache}{$cachekey.'/guess'}) {
 490                         for my $v (@{$param{source_version_cache}{$cachekey.'/guess'}}) {
 491                             $sourceversions{$v} = 1;
 492                         }
 493                         next;
 494                     }
 495                     my @srcinfo = binarytosource($pkg, $version, $arch);
 496                     if (not @srcinfo) {
 497                         # We don't have explicit information about the
 498                         # binary-to-source mapping for this version
 499                         # (yet).
 500                         print {$warnings} "There is no source info for the package '$pkg' at version '$version' with architecture '$arch'\n";
 501                         if ($param{guess_source}) {
 502                             # Lets guess it
 503                             my $pkgsrc = getpkgsrc();
 504                             if (exists $pkgsrc->{$pkg}) {
 505                                 @srcinfo = ([$pkgsrc->{$pkg}, $version]);
 506                             } elsif (getsrcpkgs($pkg)) {
 507                                 # If we're looking at a source package
 508                                 # that doesn't have a binary of the
 509                                 # same name, just try the same
 510                                 # version.
 511                                 @srcinfo = ([$pkg, $version]);
 512                             } else {
 513                                 next;
 514                             }
 515                             # store guesses in a slightly different location
 516                             $param{source_version_cache}{$cachekey.'/guess'} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
 517                         }
 518                     }
 519                     else {
 520                         # only store this if we didn't have to guess it
 521                         $param{source_version_cache}{$cachekey} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
 522                     }
 523                     $sourceversions{"$_->[0]/$_->[1]"} = 1 foreach @srcinfo;
 524                 }
 525             }
 526         }
 527     }
 528     return sort keys %sourceversions;
 529 }
 530
 531
 532
 533 1;