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