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