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 Exporter qw(import);
  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(binary_to_source 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 sort_versions);
  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 binary_to_source
 125
 126      binary_to_source(package => 'foo',
 127                       version => '1.2.3',
 128                       arch    => 'i386');
 129
 130
 131 Turn a binary package (at optional version in optional architecture)
 132 into a single (or set) of source packages (optionally) with associated
 133 versions.
 134
 135 By default, in LIST context, returns a LIST of array refs of source
 136 package, source version pairs corresponding to the binary package(s),
 137 arch(s), and verion(s) passed.
 138
 139 In SCALAR context, only the corresponding source packages are
 140 returned, concatenated with ', ' if necessary.
 141
 142 If no source can be found, returns undef in scalar context, or the
 143 empty list in list context.
 144
 145 =over
 146
 147 =item binary -- binary package name(s) as a SCALAR or ARRAYREF
 148
 149 =item version -- binary package version(s) as a SCALAR or ARRAYREF;
 150 optional, defaults to all versions.
 151
 152 =item arch -- binary package architecture(s) as a SCALAR or ARRAYREF;
 153 optional, defaults to all architectures.
 154
 155 =item source_only -- return only the source name (forced on if in
 156 SCALAR context), defaults to false.
 157
 158 =item scalar_only -- return a scalar only (forced true if in SCALAR
 159 context, also causes source_only to be true), defaults to false.
 160
 161 =item cache -- optional HASHREF to be used to cache results of
 162 binary_to_source.
 163
 164 =back
 165
 166 =cut
 167
 168 # the two global variables below are used to tie the source maps; we
 169 # probably should be retying them in long lived processes.
 170 our %_binarytosource;
 171 our %_sourcetobinary;
 172 sub binary_to_source{
 173     my %param = validate_with(params => \@_,
 174                               spec   => {binary => {type => SCALAR|ARRAYREF,
 175                                                     },
 176                                          version => {type => SCALAR|ARRAYREF,
 177                                                      optional => 1,
 178                                                     },
 179                                          arch    => {type => SCALAR|ARRAYREF,
 180                                                      optional => 1,
 181                                                     },
 182                                          source_only => {default => 0,
 183                                                         },
 184                                          scalar_only => {default => 0,
 185                                                         },
 186                                          cache => {type => HASHREF,
 187                                                    default => {},
 188                                                   },
 189                                         },
 190                              );
 191
 192     # TODO: This gets hit a lot, especially from buggyversion() - probably
 193     # need an extra cache for speed here.
 194     return () unless defined $gBinarySourceMap;
 195
 196     if ($param{scalar_only} or not wantarray) {
 197         $param{source_only} = 1;
 198         $param{scalar_only} = 1;
 199     }
 200
 201     my @source;
 202     my @binaries = grep {defined $_} make_list(exists $param{binary}?$param{binary}:[]);
 203     my @versions = grep {defined $_} make_list(exists $param{version}?$param{version}:[]);
 204     my @archs = grep {defined $_} make_list(exists $param{arch}?$param{arch}:[]);
 205     return () unless @binaries;
 206     my $cache_key = join("\1",
 207                          join("\0",@binaries),
 208                          join("\0",@versions),
 209                          join("\0",@archs),
 210                          join("\0",@param{qw(source_only scalar_only)}));
 211     if (exists $param{cache}{$cache_key}) {
 212         return $param{scalar_only} ? $param{cache}{$cache_key}[0]:
 213             @{$param{cache}{$cache_key}};
 214     }
 215     for my $binary (@binaries) {
 216         if ($binary =~ m/^src:(.+)$/) {
 217             push @source,[$1,''];
 218             next;
 219         }
 220         if (not tied %_binarytosource) {
 221             tie %_binarytosource, MLDBM => $config{binary_source_map}, O_RDONLY or
 222                 die "Unable to open $config{binary_source_map} for reading";
 223         }
 224         # avoid autovivification
 225         my $bin = $_binarytosource{$binary};
 226         next unless defined $bin;
 227         if (not @versions) {
 228             for my $ver (keys %{$bin}) {
 229                 for my $ar (keys %{$bin->{$ver}}) {
 230                     my $src = $bin->{$ver}{$ar};
 231                     next unless defined $src;
 232                     push @source,[$src->[0],$src->[1]];
 233                 }
 234             }
 235         }
 236         else {
 237             for my $version (@versions) {
 238                 next unless exists $bin->{$version};
 239                 if (exists $bin->{$version}{all}) {
 240                     push @source,dclone($bin->{$version}{all});
 241                     next;
 242                 }
 243                 my @t_archs;
 244                 if (@archs) {
 245                     @t_archs = @archs;
 246                 }
 247                 else {
 248                     @t_archs = keys %{$bin->{$version}};
 249                 }
 250                 for my $arch (@t_archs) {
 251                     push @source,dclone($bin->{$version}{$arch}) if
 252                         exists $bin->{$version}{$arch};
 253                 }
 254             }
 255         }
 256     }
 257
 258     if (not @source and not @versions and not @archs) {
 259         # ok, we haven't found any results at all. If we weren't given
 260         # a specific version and architecture, then we should try
 261         # really hard to figure out the right source
 262
 263         # if any the packages we've been given are a valid source
 264         # package name, and there's no binary of the same name (we got
 265         # here, so there isn't), return it.
 266
 267         if (not tied %_sourcetobinary) {
 268             tie %_sourcetobinary, MLDBM => $config{source_binary_map}, O_RDONLY or
 269                 die "Unable top open $gSourceBinaryMap for reading";
 270         }
 271         for my $maybe_sourcepkg (@binaries) {
 272             if (exists $_sourcetobinary{$maybe_sourcepkg}) {
 273                 push @source,[$maybe_sourcepkg,$_] for keys %{$_sourcetobinary{$maybe_sourcepkg}};
 274             }
 275         }
 276         # if @source is still empty here, it's probably a non-existant
 277         # source package, so don't return anything.
 278     }
 279
 280     my @result;
 281
 282     if ($param{source_only}) {
 283         my %uniq;
 284         for my $s (@source) {
 285             # we shouldn't need to do this, but do this temporarily to
 286             # stop the warning.
 287             next unless defined $s->[0];
 288             $uniq{$s->[0]} = 1;
 289         }
 290         @result = sort keys %uniq;
 291         if ($param{scalar_only}) {
 292             @result = join(', ',@result);
 293         }
 294     }
 295     else {
 296         my %uniq;
 297         for my $s (@source) {
 298             $uniq{$s->[0]}{$s->[1]} = 1;
 299         }
 300         for my $sn (sort keys %uniq) {
 301             push @result, [$sn, $_] for sort keys %{$uniq{$sn}};
 302         }
 303     }
 304
 305     # No $gBinarySourceMap, or it didn't have an entry for this name and
 306     # version.
 307     $param{cache}{$cache_key} = \@result;
 308     return $param{scalar_only} ? $result[0] : @result;
 309 }
 310
 311 =head2 sourcetobinary
 312
 313 Returns a list of references to triplets of binary package names, versions,
 314 and architectures corresponding to a given source package name and version.
 315 If the given source package name and version cannot be found in the database
 316 but the source package name is in the unversioned package-to-source map
 317 file, then a reference to a binary package name and version pair will be
 318 returned, without the architecture.
 319
 320 =cut
 321
 322 sub sourcetobinary {
 323     my ($srcname, $srcver) = @_;
 324
 325     if (not tied %_sourcetobinary) {
 326         tie %_sourcetobinary, MLDBM => $config{source_binary_map}, O_RDONLY or
 327             die "Unable top open $config{source_binary_map} for reading";
 328     }
 329
 330
 331
 332     # avoid autovivification
 333     my $source = $_sourcetobinary{$srcname};
 334     return () unless defined $source;
 335     if (exists $source->{$srcver}) {
 336          my $bin = $source->{$srcver};
 337          return () unless defined $bin;
 338          return @$bin;
 339     }
 340     # No $gSourceBinaryMap, or it didn't have an entry for this name and
 341     # version. Try $gPackageSource (unversioned) instead.
 342     my @srcpkgs = getsrcpkgs($srcname);
 343     return map [$_, $srcver], @srcpkgs;
 344 }
 345
 346 =head2 getversions
 347
 348 Returns versions of the package in a distribution at a specific
 349 architecture
 350
 351 =cut
 352
 353 sub getversions {
 354     my ($pkg, $dist, $arch) = @_;
 355     return get_versions(package=>$pkg,
 356                         dist => $dist,
 357                         defined $arch ? (arch => $arch):(),
 358                        );
 359 }
 360
 361
 362
 363 =head2 get_versions
 364
 365      get_versions(package=>'foopkg',
 366                   dist => 'unstable',
 367                   arch => 'i386',
 368                  );
 369
 370 Returns a list of the versions of package in the distributions and
 371 architectures listed. This routine only returns unique values.
 372
 373 =over
 374
 375 =item package -- package to return list of versions
 376
 377 =item dist -- distribution (unstable, stable, testing); can be an
 378 arrayref
 379
 380 =item arch -- architecture (i386, source, ...); can be an arrayref
 381
 382 =item time -- returns a version=>time hash at which the newest package
 383 matching this version was uploaded
 384
 385 =item source -- returns source/version instead of just versions
 386
 387 =item no_source_arch -- discards the source architecture when arch is
 388 not passed. [Used for finding the versions of binary packages only.]
 389 Defaults to 0, which does not discard the source architecture. (This
 390 may change in the future, so if you care, please code accordingly.)
 391
 392 =item return_archs -- returns a version=>[archs] hash indicating which
 393 architectures are at which versions.
 394
 395 =item largest_source_version_only -- if there is more than one source
 396 version in a particular distribution, discards all versions but the
 397 largest in that distribution. Defaults to 1, as this used to be the
 398 way that the Debian archive worked.
 399
 400 =back
 401
 402 When called in scalar context, this function will return hashrefs or
 403 arrayrefs as appropriate, in list context, it will return paired lists
 404 or unpaired lists as appropriate.
 405
 406 =cut
 407
 408 our %_versions;
 409 our %_versions_time;
 410
 411 sub get_versions{
 412      my %param = validate_with(params => \@_,
 413                                 spec   => {package => {type => SCALAR|ARRAYREF,
 414                                                       },
 415                                            dist    => {type => SCALAR|ARRAYREF,
 416                                                        default => 'unstable',
 417                                                       },
 418                                            arch    => {type => SCALAR|ARRAYREF,
 419                                                        optional => 1,
 420                                                       },
 421                                            time    => {type    => BOOLEAN,
 422                                                        default => 0,
 423                                                       },
 424                                            source  => {type    => BOOLEAN,
 425                                                        default => 0,
 426                                                       },
 427                                            no_source_arch => {type => BOOLEAN,
 428                                                               default => 0,
 429                                                              },
 430                                            return_archs => {type => BOOLEAN,
 431                                                             default => 0,
 432                                                            },
 433                                            largest_source_version_only => {type => BOOLEAN,
 434                                                                        default => 1,
 435                                                                           },
 436                                           },
 437                                );
 438      my $versions;
 439      if ($param{time}) {
 440           return () if not defined $gVersionTimeIndex;
 441           unless (tied %_versions_time) {
 442                tie %_versions_time, 'MLDBM', $gVersionTimeIndex, O_RDONLY
 443                     or die "can't open versions index $gVersionTimeIndex: $!";
 444           }
 445           $versions = \%_versions_time;
 446      }
 447      else {
 448           return () if not defined $gVersionIndex;
 449           unless (tied %_versions) {
 450                tie %_versions, 'MLDBM', $gVersionIndex, O_RDONLY
 451                     or die "can't open versions index $gVersionIndex: $!";
 452           }
 453           $versions = \%_versions;
 454      }
 455      my %versions;
 456      for my $package (make_list($param{package})) {
 457           my $source_only = 0;
 458           if ($package =~ s/^src://) {
 459                $source_only = 1;
 460           }
 461           my $version = $versions->{$package};
 462           next unless defined $version;
 463           for my $dist (make_list($param{dist})) {
 464                for my $arch (exists $param{arch}?
 465                              make_list($param{arch}):
 466                              (grep {not $param{no_source_arch} or
 467                                         $_ ne 'source'
 468                                     } $source_only?'source':keys %{$version->{$dist}})) {
 469                     next unless defined $version->{$dist}{$arch};
 470                     my @vers = ref $version->{$dist}{$arch} eq 'HASH' ?
 471                         keys %{$version->{$dist}{$arch}} :
 472                             make_list($version->{$dist}{$arch});
 473                     if ($param{largest_source_version_only} and
 474                         $arch eq 'source' and @vers > 1) {
 475                         # order the versions, then pick the biggest version number
 476                         @vers = sort_versions(@vers);
 477                         @vers = $vers[-1];
 478                     }
 479                     for my $ver (@vers) {
 480                          my $f_ver = $ver;
 481                          if ($param{source}) {
 482                               ($f_ver) = make_source_versions(package => $package,
 483                                                               arch => $arch,
 484                                                               versions => $ver);
 485                               next unless defined $f_ver;
 486                          }
 487                          if ($param{time}) {
 488                               $versions{$f_ver} = max($versions{$f_ver}||0,$version->{$dist}{$arch}{$ver});
 489                          }
 490                          else {
 491                               push @{$versions{$f_ver}},$arch;
 492                          }
 493                     }
 494                }
 495           }
 496      }
 497      if ($param{time} or $param{return_archs}) {
 498           return wantarray?%versions :\%versions;
 499      }
 500      return wantarray?keys %versions :[keys %versions];
 501 }
 502
 503
 504 =head2 makesourceversions
 505
 506      @{$cgi_var{found}} = makesourceversions($cgi_var{package},undef,@{$cgi_var{found}});
 507
 508 Canonicalize versions into source versions, which have an explicitly
 509 named source package. This is used to cope with source packages whose
 510 names have changed during their history, and with cases where source
 511 version numbers differ from binary version numbers.
 512
 513 =cut
 514
 515 our %_sourceversioncache = ();
 516 sub makesourceversions {
 517     my ($package,$arch,@versions) = @_;
 518     die "Package $package is multiple packages; split on , and call makesourceversions multiple times"
 519          if $package =~ /,/;
 520     return make_source_versions(package => $package,
 521                                 (defined $arch)?(arch => $arch):(),
 522                                 versions => \@versions
 523                                );
 524 }
 525
 526 =head2 make_source_versions
 527
 528      make_source_versions(package => 'foo',
 529                           arch    => 'source',
 530                           versions => '0.1.1',
 531                           guess_source => 1,
 532                           warnings => \$warnings,
 533                          );
 534
 535 An extended version of makesourceversions (which calls this function
 536 internally) that allows for multiple packages, architectures, and
 537 outputs warnings and debugging information to provided SCALARREFs or
 538 HANDLEs.
 539
 540 The guess_source option determines whether the source package is
 541 guessed at if there is no obviously correct package. Things that use
 542 this function for non-transient output should set this to false,
 543 things that use it for transient output can set this to true.
 544 Currently it defaults to true, but that is not a sane option.
 545
 546
 547 =cut
 548
 549 sub make_source_versions {
 550     my %param = validate_with(params => \@_,
 551                               spec   => {package => {type => SCALAR|ARRAYREF,
 552                                                     },
 553                                          arch    => {type => SCALAR|ARRAYREF|UNDEF,
 554                                                      default => ''
 555                                                     },
 556                                          versions => {type => SCALAR|ARRAYREF,
 557                                                       default => [],
 558                                                      },
 559                                          guess_source => {type => BOOLEAN,
 560                                                           default => 1,
 561                                                          },
 562                                          source_version_cache => {type => HASHREF,
 563                                                                   optional => 1,
 564                                                                  },
 565                                          debug    => {type => SCALARREF|HANDLE,
 566                                                       optional => 1,
 567                                                      },
 568                                          warnings => {type => SCALARREF|HANDLE,
 569                                                       optional => 1,
 570                                                      },
 571                                         },
 572                              );
 573     my ($warnings) = globify_scalar(exists $param{warnings}?$param{warnings}:undef);
 574
 575     my @packages = grep {defined $_ and length $_ } make_list($param{package});
 576     my @archs    = grep {defined $_ } make_list ($param{arch});
 577     if (not @archs) {
 578         push @archs, '';
 579     }
 580     if (not exists $param{source_version_cache}) {
 581         $param{source_version_cache} = \%_sourceversioncache;
 582     }
 583     if (grep {/,/} make_list($param{package})) {
 584         croak "Package names contain ,; split on /,/ and call make_source_versions with an arrayref of packages"
 585     }
 586     my %sourceversions;
 587     for my $version (make_list($param{versions})) {
 588         if ($version =~ m{(.+)/([^/]+)$}) {
 589             # Already a source version.
 590             $sourceversions{$version} = 1;
 591             next unless exists $param{warnings};
 592             # check to see if this source version is even possible
 593             my @bin_versions = sourcetobinary($1,$2);
 594             if (not @bin_versions or
 595                 @{$bin_versions[0]} != 3) {
 596                 print {$warnings} "The source $1 and version $2 do not appear to match any binary packages\n";
 597             }
 598         } else {
 599             if (not @packages) {
 600                 croak "You must provide at least one package if the versions are not fully qualified";
 601             }
 602             for my $pkg (@packages) {
 603                 if ($pkg =~ /^src:(.+)/) {
 604                     $sourceversions{"$1/$version"} = 1;
 605                     next unless exists $param{warnings};
 606                     # check to see if this source version is even possible
 607                     my @bin_versions = sourcetobinary($1,$version);
 608                     if (not @bin_versions or
 609                         @{$bin_versions[0]} != 3) {
 610                         print {$warnings} "The source '$1' and version '$version' do not appear to match any binary packages\n";
 611                     }
 612                     next;
 613                 }
 614                 for my $arch (@archs) {
 615                     my $cachearch = (defined $arch) ? $arch : '';
 616                     my $cachekey = "$pkg/$cachearch/$version";
 617                     if (exists($param{source_version_cache}{$cachekey})) {
 618                         for my $v (@{$param{source_version_cache}{$cachekey}}) {
 619                             $sourceversions{$v} = 1;
 620                         }
 621                         next;
 622                     }
 623                     elsif ($param{guess_source} and
 624                            exists$param{source_version_cache}{$cachekey.'/guess'}) {
 625                         for my $v (@{$param{source_version_cache}{$cachekey.'/guess'}}) {
 626                             $sourceversions{$v} = 1;
 627                         }
 628                         next;
 629                     }
 630                     my @srcinfo = binary_to_source(binary => $pkg,
 631                                                    version => $version,
 632                                                    length($arch)?(arch    => $arch):());
 633                     if (not @srcinfo) {
 634                         # We don't have explicit information about the
 635                         # binary-to-source mapping for this version
 636                         # (yet).
 637                         print {$warnings} "There is no source info for the package '$pkg' at version '$version' with architecture '$arch'\n";
 638                         if ($param{guess_source}) {
 639                             # Lets guess it
 640                             my $pkgsrc = getpkgsrc();
 641                             if (exists $pkgsrc->{$pkg}) {
 642                                 @srcinfo = ([$pkgsrc->{$pkg}, $version]);
 643                             } elsif (getsrcpkgs($pkg)) {
 644                                 # If we're looking at a source package
 645                                 # that doesn't have a binary of the
 646                                 # same name, just try the same
 647                                 # version.
 648                                 @srcinfo = ([$pkg, $version]);
 649                             } else {
 650                                 next;
 651                             }
 652                             # store guesses in a slightly different location
 653                             $param{source_version_cache}{$cachekey.'/guess'} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
 654                         }
 655                     }
 656                     else {
 657                         # only store this if we didn't have to guess it
 658                         $param{source_version_cache}{$cachekey} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
 659                     }
 660                     $sourceversions{"$_->[0]/$_->[1]"} = 1 foreach @srcinfo;
 661                 }
 662             }
 663         }
 664     }
 665     return sort keys %sourceversions;
 666 }
 667
 668
 669
 670 1;