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 (not tied %_binarytosource) {
 148          tie %_binarytosource, MLDBM => $gBinarySourceMap, O_RDONLY or
 149               die "Unable to open $gBinarySourceMap for reading";
 150     }
 151
 152     # avoid autovivification
 153     my $binary = $_binarytosource{$binname};
 154     return () unless defined $binary;
 155     my %binary = %{$binary};
 156     if (not defined $binver) {
 157          my %uniq;
 158          for my $ver (keys %binary) {
 159               for my $ar (keys %{$binary{$ver}}) {
 160                    my $src = $binary{$ver}{$ar};
 161                    next unless defined $src;
 162                    $uniq{$src->[0]} = 1;
 163               }
 164          }
 165          return keys %uniq;
 166     }
 167     elsif (exists $binary{$binver}) {
 168          if (defined $binarch) {
 169               my $src = $binary{$binver}{$binarch};
 170               if (not defined $src and exists $binary{$binver}{all}) {
 171                   $src = $binary{$binver}{all};
 172               }
 173               return () unless defined $src; # not on this arch
 174               # Copy the data to avoid tiedness problems.
 175               return dclone($src);
 176          } else {
 177               # Get (srcname, srcver) pairs for all architectures and
 178               # remove any duplicates. This involves some slightly tricky
 179               # multidimensional hashing; sorry. Fortunately there'll
 180               # usually only be one pair returned.
 181               my %uniq;
 182               for my $ar (keys %{$binary{$binver}}) {
 183                    my $src = $binary{$binver}{$ar};
 184                    next unless defined $src;
 185                    $uniq{$src->[0]}{$src->[1]} = 1;
 186               }
 187               my @uniq;
 188               for my $sn (sort keys %uniq) {
 189                    push @uniq, [$sn, $_] for sort keys %{$uniq{$sn}};
 190               }
 191               return @uniq;
 192          }
 193     }
 194
 195     # No $gBinarySourceMap, or it didn't have an entry for this name and
 196     # version.
 197     return ();
 198 }
 199
 200 =head2 sourcetobinary
 201
 202 Returns a list of references to triplets of binary package names, versions,
 203 and architectures corresponding to a given source package name and version.
 204 If the given source package name and version cannot be found in the database
 205 but the source package name is in the unversioned package-to-source map
 206 file, then a reference to a binary package name and version pair will be
 207 returned, without the architecture.
 208
 209 =cut
 210
 211 our %_sourcetobinary;
 212 sub sourcetobinary {
 213     my ($srcname, $srcver) = @_;
 214
 215     if (not tied %_sourcetobinary) {
 216          tie %_sourcetobinary, MLDBM => $gSourceBinaryMap, O_RDONLY or
 217               die "Unable top open $gSourceBinaryMap for reading";
 218     }
 219
 220
 221
 222     # avoid autovivification
 223     my $source = $_sourcetobinary{$srcname};
 224     return () unless defined $source;
 225     if (exists $source->{$srcver}) {
 226          my $bin = $source->{$srcver};
 227          return () unless defined $bin;
 228          return @$bin;
 229     }
 230     # No $gSourceBinaryMap, or it didn't have an entry for this name and
 231     # version. Try $gPackageSource (unversioned) instead.
 232     my @srcpkgs = getsrcpkgs($srcname);
 233     return map [$_, $srcver], @srcpkgs;
 234 }
 235
 236 =head2 getversions
 237
 238 Returns versions of the package in a distribution at a specific
 239 architecture
 240
 241 =cut
 242
 243 sub getversions {
 244     my ($pkg, $dist, $arch) = @_;
 245     return get_versions(package=>$pkg,
 246                         dist => $dist,
 247                         defined $arch ? (arch => $arch):(),
 248                        );
 249 }
 250
 251
 252
 253 =head2 get_versions
 254
 255      get_versions(package=>'foopkg',
 256                   dist => 'unstable',
 257                   arch => 'i386',
 258                  );
 259
 260 Returns a list of the versions of package in the distributions and
 261 architectures listed. This routine only returns unique values.
 262
 263 =over
 264
 265 =item package -- package to return list of versions
 266
 267 =item dist -- distribution (unstable, stable, testing); can be an
 268 arrayref
 269
 270 =item arch -- architecture (i386, source, ...); can be an arrayref
 271
 272 =item time -- returns a version=>time hash at which the newest package
 273 matching this version was uploaded
 274
 275 =item source -- returns source/version instead of just versions
 276
 277 =item no_source_arch -- discards the source architecture when arch is
 278 not passed. [Used for finding the versions of binary packages only.]
 279 Defaults to 0, which does not discard the source architecture. (This
 280 may change in the future, so if you care, please code accordingly.)
 281
 282 =item return_archs -- returns a version=>[archs] hash indicating which
 283 architectures are at which versions.
 284
 285 =back
 286
 287 When called in scalar context, this function will return hashrefs or
 288 arrayrefs as appropriate, in list context, it will return paired lists
 289 or unpaired lists as appropriate.
 290
 291 =cut
 292
 293 our %_versions;
 294 our %_versions_time;
 295
 296 sub get_versions{
 297      my %param = validate_with(params => \@_,
 298                                 spec   => {package => {type => SCALAR|ARRAYREF,
 299                                                       },
 300                                            dist    => {type => SCALAR|ARRAYREF,
 301                                                        default => 'unstable',
 302                                                       },
 303                                            arch    => {type => SCALAR|ARRAYREF,
 304                                                        optional => 1,
 305                                                       },
 306                                            time    => {type    => BOOLEAN,
 307                                                        default => 0,
 308                                                       },
 309                                            source  => {type    => BOOLEAN,
 310                                                        default => 0,
 311                                                       },
 312                                            no_source_arch => {type => BOOLEAN,
 313                                                               default => 0,
 314                                                              },
 315                                            return_archs => {type => BOOLEAN,
 316                                                             default => 0,
 317                                                            },
 318                                           },
 319                                );
 320      my $versions;
 321      if ($param{time}) {
 322           return () if not defined $gVersionTimeIndex;
 323           unless (tied %_versions_time) {
 324                tie %_versions_time, 'MLDBM', $gVersionTimeIndex, O_RDONLY
 325                     or die "can't open versions index $gVersionTimeIndex: $!";
 326           }
 327           $versions = \%_versions_time;
 328      }
 329      else {
 330           return () if not defined $gVersionIndex;
 331           unless (tied %_versions) {
 332                tie %_versions, 'MLDBM', $gVersionIndex, O_RDONLY
 333                     or die "can't open versions index $gVersionIndex: $!";
 334           }
 335           $versions = \%_versions;
 336      }
 337      my %versions;
 338      for my $package (make_list($param{package})) {
 339           my $version = $versions->{$package};
 340           next unless defined $version;
 341           for my $dist (make_list($param{dist})) {
 342                for my $arch (exists $param{arch}?
 343                              make_list($param{arch}):
 344                              (grep {not $param{no_source_arch} or
 345                                         $_ ne 'source'
 346                                     } keys %{$version->{$dist}})) {
 347                     next unless defined $version->{$dist}{$arch};
 348                     for my $ver (ref $version->{$dist}{$arch} ?
 349                                  keys %{$version->{$dist}{$arch}} :
 350                                  $version->{$dist}{$arch}
 351                                 ) {
 352                          my $f_ver = $ver;
 353                          if ($param{source}) {
 354                               ($f_ver) = make_source_versions(package => $package,
 355                                                               arch => $arch,
 356                                                               versions => $ver);
 357                               next unless defined $f_ver;
 358                          }
 359                          if ($param{time}) {
 360                               $versions{$f_ver} = max($versions{$f_ver}||0,$version->{$dist}{$arch}{$ver});
 361                          }
 362                          else {
 363                               push @{$versions{$f_ver}},$arch;
 364                          }
 365                     }
 366                }
 367           }
 368      }
 369      if ($param{time} or $param{return_archs}) {
 370           return wantarray?%versions :\%versions;
 371      }
 372      return wantarray?keys %versions :[keys %versions];
 373 }
 374
 375
 376 =head2 makesourceversions
 377
 378      @{$cgi_var{found}} = makesourceversions($cgi_var{package},undef,@{$cgi_var{found}});
 379
 380 Canonicalize versions into source versions, which have an explicitly
 381 named source package. This is used to cope with source packages whose
 382 names have changed during their history, and with cases where source
 383 version numbers differ from binary version numbers.
 384
 385 =cut
 386
 387 our %_sourceversioncache = ();
 388 sub makesourceversions {
 389     my ($package,$arch,@versions) = @_;
 390     die "Package $package is multiple packages; split on , and call makesourceversions multiple times"
 391          if $package =~ /,/;
 392     return make_source_versions(package => $package,
 393                                 (defined $arch)?(arch => $arch):(),
 394                                 versions => \@versions
 395                                );
 396 }
 397
 398 =head2 make_source_versions
 399
 400      make_source_versions(package => 'foo',
 401                           arch    => 'source',
 402                           versions => '0.1.1',
 403                           guess_source => 1,
 404                           debug    => \$debug,
 405                           warnings => \$warnings,
 406                          );
 407
 408 An extended version of makesourceversions (which calls this function
 409 internally) that allows for multiple packages, architectures, and
 410 outputs warnings and debugging information to provided SCALARREFs or
 411 HANDLEs.
 412
 413 The guess_source option determines whether the source package is
 414 guessed at if there is no obviously correct package. Things that use
 415 this function for non-transient output should set this to false,
 416 things that use it for transient output can set this to true.
 417 Currently it defaults to true, but that is not a sane option.
 418
 419
 420 =cut
 421
 422 sub make_source_versions {
 423     my %param = validate_with(params => \@_,
 424                               spec   => {package => {type => SCALAR|ARRAYREF,
 425                                                     },
 426                                          arch    => {type => SCALAR|ARRAYREF,
 427                                                      default => ''
 428                                                     },
 429                                          versions => {type => SCALAR|ARRAYREF,
 430                                                       default => [],
 431                                                      },
 432                                          guess_source => {type => BOOLEAN,
 433                                                           default => 1,
 434                                                          },
 435                                          source_version_cache => {type => HASHREF,
 436                                                                   optional => 1,
 437                                                                  },
 438                                          debug    => {type => SCALARREF|HANDLE,
 439                                                       optional => 1,
 440                                                      },
 441                                          warnings => {type => SCALARREF|HANDLE,
 442                                                       optional => 1,
 443                                                      },
 444                                         },
 445                              );
 446     my ($warnings) = globify_scalar(exists $param{warnings}?$param{warnings}:undef);
 447     my ($debug)    = globify_scalar(exists $param{debug}   ?$param{debug}   :undef);
 448
 449     my @packages = grep {defined $_ and length $_ } make_list($param{package});
 450     my @archs    = grep {defined $_ } make_list ($param{arch});
 451     if (not @archs) {
 452         push @archs, '';
 453     }
 454     if (not exists $param{source_version_cache}) {
 455         $param{source_version_cache} = \%_sourceversioncache;
 456     }
 457     if (grep {/,/} make_list($param{package})) {
 458         croak "Package names contain ,; split on /,/ and call make_source_versions with an arrayref of packages"
 459     }
 460     my %sourceversions;
 461     for my $version (make_list($param{versions})) {
 462         if ($version =~ m{(.+)/([^/]+)$}) {
 463             # check to see if this source version is even possible
 464             my @bin_versions = sourcetobinary($1,$2);
 465             if (not @bin_versions or
 466                 @{$bin_versions[0]} != 3) {
 467                 print {$warnings} "The source $1 and version $2 do not appear to match any binary packages\n";
 468             }
 469             # Already a source version.
 470             $sourceversions{$version} = 1;
 471         } else {
 472             if (not @packages) {
 473                 croak "You must provide at least one package if the versions are not fully qualified";
 474             }
 475             for my $pkg (@packages) {
 476                 for my $arch (@archs) {
 477                     my $cachearch = (defined $arch) ? $arch : '';
 478                     my $cachekey = "$pkg/$cachearch/$version";
 479                     if (exists($param{source_version_cache}{$cachekey})) {
 480                         for my $v (@{$param{source_version_cache}{$cachekey}}) {
 481                             $sourceversions{$v} = 1;
 482                         }
 483                         next;
 484                     }
 485                     elsif ($param{guess_source} and
 486                            exists$param{source_version_cache}{$cachekey.'/guess'}) {
 487                         for my $v (@{$param{source_version_cache}{$cachekey}}) {
 488                             $sourceversions{$v} = 1;
 489                         }
 490                         next;
 491                     }
 492                     my @srcinfo = binarytosource($pkg, $version, $arch);
 493                     if (not @srcinfo) {
 494                         # We don't have explicit information about the
 495                         # binary-to-source mapping for this version
 496                         # (yet).
 497                         print {$warnings} "There is no source info for the package '$pkg' at version '$version' with architecture '$arch'\n";
 498                         if ($param{guess_source}) {
 499                             # Lets guess it
 500                             my $pkgsrc = getpkgsrc();
 501                             if (exists $pkgsrc->{$pkg}) {
 502                                 @srcinfo = ([$pkgsrc->{$pkg}, $version]);
 503                             } elsif (getsrcpkgs($pkg)) {
 504                                 # If we're looking at a source package
 505                                 # that doesn't have a binary of the
 506                                 # same name, just try the same
 507                                 # version.
 508                                 @srcinfo = ([$pkg, $version]);
 509                             } else {
 510                                 next;
 511                             }
 512                             # store guesses in a slightly different location
 513                             $param{source_version_cache}{$cachekey.'/guess'} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
 514                         }
 515                     }
 516                     else {
 517                         # only store this if we didn't have to guess it
 518                         $param{source_version_cache}{$cachekey} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
 519                     }
 520                     $sourceversions{"$_->[0]/$_->[1]"} = 1 foreach @srcinfo;
 521                 }
 522             }
 523         }
 524     }
 525     return sort keys %sourceversions;
 526 }
 527
 528
 529
 530 1;