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