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