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