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