Debbugs/Packages.pm

   1 # This module is part of debbugs, and is released
   2 # under the terms of the GPL version 2, or any later
   3 # version at your option.
   4 # See the file README and COPYING for more information.
   5 #
   6 # [Other people have contributed to this file; their copyrights should
   7 # go here too.]
   8 # Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
   9
  10 package Debbugs::Packages;
  11
  12 use warnings;
  13 use strict;
  14
  15 use Exporter qw(import);
  16 use vars qw($VERSION @EXPORT_OK %EXPORT_TAGS @EXPORT);
  17
  18 use Carp;
  19
  20 use Debbugs::Config qw(:config :globals);
  21
  22 BEGIN {
  23     $VERSION = 1.00;
  24
  25      @EXPORT = ();
  26      %EXPORT_TAGS = (versions => [qw(getversions get_versions make_source_versions)],
  27                      mapping  => [qw(getpkgsrc getpkgcomponent getsrcpkgs),
  28                                   qw(binary_to_source sourcetobinary makesourceversions)
  29                                  ],
  30                     );
  31      @EXPORT_OK = ();
  32      Exporter::export_ok_tags(qw(versions mapping));
  33      $EXPORT_TAGS{all} = [@EXPORT_OK];
  34 }
  35
  36 use Fcntl qw(O_RDONLY);
  37 use MLDBM qw(DB_File Storable);
  38 use Storable qw(dclone);
  39 use Params::Validate qw(validate_with :types);
  40 use Debbugs::Common qw(make_list globify_scalar sort_versions);
  41
  42 use List::Util qw(min max);
  43
  44 use IO::File;
  45
  46 $MLDBM::DumpMeth = 'portable';
  47 $MLDBM::RemoveTaint = 1;
  48
  49 =head1 NAME
  50
  51 Debbugs::Packages - debbugs binary/source package handling
  52
  53 =head1 DESCRIPTION
  54
  55 The Debbugs::Packages module provides support functions to map binary
  56 packages to their corresponding source packages and vice versa. (This makes
  57 sense for software distributions, where developers may work on a single
  58 source package which produces several binary packages for use by users; it
  59 may not make sense in other contexts.)
  60
  61 =head1 METHODS
  62
  63 =head2 getpkgsrc
  64
  65 Returns a reference to a hash of binary package names to their corresponding
  66 source package names.
  67
  68 =cut
  69
  70 our $_pkgsrc;
  71 our $_pkgcomponent;
  72 our $_srcpkg;
  73 sub getpkgsrc {
  74     return $_pkgsrc if $_pkgsrc;
  75     return {} unless defined $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                                          schema => {type => OBJECT,
 190                                                     optional => 1,
 191                                                    },
 192                                         },
 193                              );
 194
 195     # TODO: This gets hit a lot, especially from buggyversion() - probably
 196     # need an extra cache for speed here.
 197     return () unless defined $gBinarySourceMap or defined $param{schema};
 198
 199     if ($param{scalar_only} or not wantarray) {
 200         $param{source_only} = 1;
 201         $param{scalar_only} = 1;
 202     }
 203
 204     my @source;
 205     my @binaries = grep {defined $_} make_list(exists $param{binary}?$param{binary}:[]);
 206     my @versions = grep {defined $_} make_list(exists $param{version}?$param{version}:[]);
 207     my @archs = grep {defined $_} make_list(exists $param{arch}?$param{arch}:[]);
 208     return () unless @binaries;
 209
 210     # any src:foo is source package foo with unspecified version
 211     @source = map {/^src:(.+)$/?
 212                        [$1,'']:()} @binaries;
 213     @binaries = grep {$_ !~ /^src:/} @binaries;
 214     if ($param{schema}) {
 215         if ($param{source_only}) {
 216             @source = map {$_->[0]} @source;
 217             my $src_rs = $param{schema}->resultset('SrcPkg')->
 218                 search_rs({'binpkg.pkg' => [@binaries],
 219                            @versions?('bin_vers.ver'    => [@versions]):(),
 220                            @archs?('arch.arch' => [@archs]):(),
 221                           },
 222                          {join => {'src_vers'=>
 223                                   {'bin_vers'=> ['arch','bin_pkg']}
 224                                   },
 225                           distinct => 1,
 226                          },
 227                          );
 228             push @source,
 229                 map {$_->pkg} $src_rs->all;
 230             if ($param{scalar_only}) {
 231                 return join(',',@source);
 232             }
 233             return @source;
 234
 235         }
 236         my $src_rs = $param{schema}->resultset('SrcVer')->
 237             search_rs({'bin_pkg.pkg' => [@binaries],
 238                        @versions?('bin_vers.ver' => [@versions]):(),
 239                        @archs?('arch.arch' => [@archs]):(),
 240                       },
 241                      {join => ['src_pkg',
 242                               {'bin_vers' => ['arch','binpkg']},
 243                               ],
 244                       distinct => 1,
 245                      },
 246                      );
 247         push @source,
 248             map {[$_->get_column('src_pkg.pkg'),
 249                   $_->get_column('src_ver.ver'),
 250                  ]} $src_rs->all;
 251         if (not @source and not @versions and not @archs) {
 252             $src_rs = $param{schema}->resultset('SrcPkg')->
 253                 search_rs({pkg => [@binaries]},
 254                          {distinct => 1},
 255                          );
 256             push @source,
 257                 map {[$_->pkg,
 258                      ]} $src_rs->all;
 259         }
 260         return @source;
 261     }
 262     my $cache_key = join("\1",
 263                          join("\0",@binaries),
 264                          join("\0",@versions),
 265                          join("\0",@archs),
 266                          join("\0",@param{qw(source_only scalar_only)}));
 267     if (exists $param{cache}{$cache_key}) {
 268         return $param{scalar_only} ? $param{cache}{$cache_key}[0]:
 269             @{$param{cache}{$cache_key}};
 270     }
 271     for my $binary (@binaries) {
 272         if (not tied %_binarytosource) {
 273             tie %_binarytosource, MLDBM => $config{binary_source_map}, O_RDONLY or
 274                 die "Unable to open $config{binary_source_map} for reading";
 275         }
 276         # avoid autovivification
 277         my $bin = $_binarytosource{$binary};
 278         next unless defined $bin;
 279         if (not @versions) {
 280             for my $ver (keys %{$bin}) {
 281                 for my $ar (keys %{$bin->{$ver}}) {
 282                     my $src = $bin->{$ver}{$ar};
 283                     next unless defined $src;
 284                     push @source,[$src->[0],$src->[1]];
 285                 }
 286             }
 287         }
 288         else {
 289             my $found_one_version = 0;
 290             for my $version (@versions) {
 291                 next unless exists $bin->{$version};
 292                 if (exists $bin->{$version}{all}) {
 293                     push @source,dclone($bin->{$version}{all});
 294                     next;
 295                 }
 296                 my @t_archs;
 297                 if (@archs) {
 298                     @t_archs = @archs;
 299                 }
 300                 else {
 301                     @t_archs = keys %{$bin->{$version}};
 302                 }
 303                 for my $arch (@t_archs) {
 304                     push @source,dclone($bin->{$version}{$arch}) if
 305                         exists $bin->{$version}{$arch};
 306                 }
 307             }
 308         }
 309     }
 310
 311     if (not @source and not @versions and not @archs) {
 312         # ok, we haven't found any results at all. If we weren't given
 313         # a specific version and architecture, then we should try
 314         # really hard to figure out the right source
 315
 316         # if any the packages we've been given are a valid source
 317         # package name, and there's no binary of the same name (we got
 318         # here, so there isn't), return it.
 319
 320         if (not tied %_sourcetobinary) {
 321             tie %_sourcetobinary, MLDBM => $config{source_binary_map}, O_RDONLY or
 322                 die "Unable top open $gSourceBinaryMap for reading";
 323         }
 324         for my $maybe_sourcepkg (@binaries) {
 325             if (exists $_sourcetobinary{$maybe_sourcepkg}) {
 326                 push @source,[$maybe_sourcepkg,$_] for keys %{$_sourcetobinary{$maybe_sourcepkg}};
 327             }
 328         }
 329         # if @source is still empty here, it's probably a non-existant
 330         # source package, so don't return anything.
 331     }
 332
 333     my @result;
 334
 335     if ($param{source_only}) {
 336         my %uniq;
 337         for my $s (@source) {
 338             # we shouldn't need to do this, but do this temporarily to
 339             # stop the warning.
 340             next unless defined $s->[0];
 341             $uniq{$s->[0]} = 1;
 342         }
 343         @result = sort keys %uniq;
 344         if ($param{scalar_only}) {
 345             @result = join(', ',@result);
 346         }
 347     }
 348     else {
 349         my %uniq;
 350         for my $s (@source) {
 351             $uniq{$s->[0]}{$s->[1]} = 1;
 352         }
 353         for my $sn (sort keys %uniq) {
 354             push @result, [$sn, $_] for sort keys %{$uniq{$sn}};
 355         }
 356     }
 357
 358     # No $gBinarySourceMap, or it didn't have an entry for this name and
 359     # version.
 360     $param{cache}{$cache_key} = \@result;
 361     return $param{scalar_only} ? $result[0] : @result;
 362 }
 363
 364 =head2 sourcetobinary
 365
 366 Returns a list of references to triplets of binary package names, versions,
 367 and architectures corresponding to a given source package name and version.
 368 If the given source package name and version cannot be found in the database
 369 but the source package name is in the unversioned package-to-source map
 370 file, then a reference to a binary package name and version pair will be
 371 returned, without the architecture.
 372
 373 =cut
 374
 375 sub sourcetobinary {
 376     my ($srcname, $srcver) = @_;
 377
 378     if (not tied %_sourcetobinary) {
 379         tie %_sourcetobinary, MLDBM => $config{source_binary_map}, O_RDONLY or
 380             die "Unable top open $config{source_binary_map} for reading";
 381     }
 382
 383
 384
 385     # avoid autovivification
 386     my $source = $_sourcetobinary{$srcname};
 387     return () unless defined $source;
 388     if (exists $source->{$srcver}) {
 389          my $bin = $source->{$srcver};
 390          return () unless defined $bin;
 391          return @$bin;
 392     }
 393     # No $gSourceBinaryMap, or it didn't have an entry for this name and
 394     # version. Try $gPackageSource (unversioned) instead.
 395     my @srcpkgs = getsrcpkgs($srcname);
 396     return map [$_, $srcver], @srcpkgs;
 397 }
 398
 399 =head2 getversions
 400
 401 Returns versions of the package in a distribution at a specific
 402 architecture
 403
 404 =cut
 405
 406 sub getversions {
 407     my ($pkg, $dist, $arch) = @_;
 408     return get_versions(package=>$pkg,
 409                         dist => $dist,
 410                         defined $arch ? (arch => $arch):(),
 411                        );
 412 }
 413
 414
 415
 416 =head2 get_versions
 417
 418      get_versions(package=>'foopkg',
 419                   dist => 'unstable',
 420                   arch => 'i386',
 421                  );
 422
 423 Returns a list of the versions of package in the distributions and
 424 architectures listed. This routine only returns unique values.
 425
 426 =over
 427
 428 =item package -- package to return list of versions
 429
 430 =item dist -- distribution (unstable, stable, testing); can be an
 431 arrayref
 432
 433 =item arch -- architecture (i386, source, ...); can be an arrayref
 434
 435 =item time -- returns a version=>time hash at which the newest package
 436 matching this version was uploaded
 437
 438 =item source -- returns source/version instead of just versions
 439
 440 =item no_source_arch -- discards the source architecture when arch is
 441 not passed. [Used for finding the versions of binary packages only.]
 442 Defaults to 0, which does not discard the source architecture. (This
 443 may change in the future, so if you care, please code accordingly.)
 444
 445 =item return_archs -- returns a version=>[archs] hash indicating which
 446 architectures are at which versions.
 447
 448 =item largest_source_version_only -- if there is more than one source
 449 version in a particular distribution, discards all versions but the
 450 largest in that distribution. Defaults to 1, as this used to be the
 451 way that the Debian archive worked.
 452
 453 =back
 454
 455 When called in scalar context, this function will return hashrefs or
 456 arrayrefs as appropriate, in list context, it will return paired lists
 457 or unpaired lists as appropriate.
 458
 459 =cut
 460
 461 our %_versions;
 462 our %_versions_time;
 463
 464 sub get_versions{
 465      my %param = validate_with(params => \@_,
 466                                 spec   => {package => {type => SCALAR|ARRAYREF,
 467                                                       },
 468                                            dist    => {type => SCALAR|ARRAYREF,
 469                                                        default => 'unstable',
 470                                                       },
 471                                            arch    => {type => SCALAR|ARRAYREF,
 472                                                        optional => 1,
 473                                                       },
 474                                            time    => {type    => BOOLEAN,
 475                                                        default => 0,
 476                                                       },
 477                                            source  => {type    => BOOLEAN,
 478                                                        default => 0,
 479                                                       },
 480                                            no_source_arch => {type => BOOLEAN,
 481                                                               default => 0,
 482                                                              },
 483                                            return_archs => {type => BOOLEAN,
 484                                                             default => 0,
 485                                                            },
 486                                            largest_source_version_only => {type => BOOLEAN,
 487                                                                        default => 1,
 488                                                                           },
 489                                           },
 490                                );
 491      my $versions;
 492      if ($param{time}) {
 493           return () if not defined $gVersionTimeIndex;
 494           unless (tied %_versions_time) {
 495                tie %_versions_time, 'MLDBM', $gVersionTimeIndex, O_RDONLY
 496                     or die "can't open versions index $gVersionTimeIndex: $!";
 497           }
 498           $versions = \%_versions_time;
 499      }
 500      else {
 501           return () if not defined $gVersionIndex;
 502           unless (tied %_versions) {
 503                tie %_versions, 'MLDBM', $gVersionIndex, O_RDONLY
 504                     or die "can't open versions index $gVersionIndex: $!";
 505           }
 506           $versions = \%_versions;
 507      }
 508      my %versions;
 509      for my $package (make_list($param{package})) {
 510           my $source_only = 0;
 511           if ($package =~ s/^src://) {
 512                $source_only = 1;
 513           }
 514           my $version = $versions->{$package};
 515           next unless defined $version;
 516           for my $dist (make_list($param{dist})) {
 517                for my $arch (exists $param{arch}?
 518                              make_list($param{arch}):
 519                              (grep {not $param{no_source_arch} or
 520                                         $_ ne 'source'
 521                                     } $source_only?'source':keys %{$version->{$dist}})) {
 522                     next unless defined $version->{$dist}{$arch};
 523                     my @vers = ref $version->{$dist}{$arch} eq 'HASH' ?
 524                         keys %{$version->{$dist}{$arch}} :
 525                             make_list($version->{$dist}{$arch});
 526                     if ($param{largest_source_version_only} and
 527                         $arch eq 'source' and @vers > 1) {
 528                         # order the versions, then pick the biggest version number
 529                         @vers = sort_versions(@vers);
 530                         @vers = $vers[-1];
 531                     }
 532                     for my $ver (@vers) {
 533                          my $f_ver = $ver;
 534                          if ($param{source}) {
 535                               ($f_ver) = make_source_versions(package => $package,
 536                                                               arch => $arch,
 537                                                               versions => $ver);
 538                               next unless defined $f_ver;
 539                          }
 540                          if ($param{time}) {
 541                               $versions{$f_ver} = max($versions{$f_ver}||0,$version->{$dist}{$arch}{$ver});
 542                          }
 543                          else {
 544                               push @{$versions{$f_ver}},$arch;
 545                          }
 546                     }
 547                }
 548           }
 549      }
 550      if ($param{time} or $param{return_archs}) {
 551           return wantarray?%versions :\%versions;
 552      }
 553      return wantarray?keys %versions :[keys %versions];
 554 }
 555
 556
 557 =head2 makesourceversions
 558
 559      @{$cgi_var{found}} = makesourceversions($cgi_var{package},undef,@{$cgi_var{found}});
 560
 561 Canonicalize versions into source versions, which have an explicitly
 562 named source package. This is used to cope with source packages whose
 563 names have changed during their history, and with cases where source
 564 version numbers differ from binary version numbers.
 565
 566 =cut
 567
 568 our %_sourceversioncache = ();
 569 sub makesourceversions {
 570     my ($package,$arch,@versions) = @_;
 571     die "Package $package is multiple packages; split on , and call makesourceversions multiple times"
 572          if $package =~ /,/;
 573     return make_source_versions(package => $package,
 574                                 (defined $arch)?(arch => $arch):(),
 575                                 versions => \@versions
 576                                );
 577 }
 578
 579 =head2 make_source_versions
 580
 581      make_source_versions(package => 'foo',
 582                           arch    => 'source',
 583                           versions => '0.1.1',
 584                           guess_source => 1,
 585                           debug    => \$debug,
 586                           warnings => \$warnings,
 587                          );
 588
 589 An extended version of makesourceversions (which calls this function
 590 internally) that allows for multiple packages, architectures, and
 591 outputs warnings and debugging information to provided SCALARREFs or
 592 HANDLEs.
 593
 594 The guess_source option determines whether the source package is
 595 guessed at if there is no obviously correct package. Things that use
 596 this function for non-transient output should set this to false,
 597 things that use it for transient output can set this to true.
 598 Currently it defaults to true, but that is not a sane option.
 599
 600
 601 =cut
 602
 603 sub make_source_versions {
 604     my %param = validate_with(params => \@_,
 605                               spec   => {package => {type => SCALAR|ARRAYREF,
 606                                                     },
 607                                          arch    => {type => SCALAR|ARRAYREF|UNDEF,
 608                                                      default => ''
 609                                                     },
 610                                          versions => {type => SCALAR|ARRAYREF,
 611                                                       default => [],
 612                                                      },
 613                                          guess_source => {type => BOOLEAN,
 614                                                           default => 1,
 615                                                          },
 616                                          source_version_cache => {type => HASHREF,
 617                                                                   optional => 1,
 618                                                                  },
 619                                          debug    => {type => SCALARREF|HANDLE,
 620                                                       optional => 1,
 621                                                      },
 622                                          warnings => {type => SCALARREF|HANDLE,
 623                                                       optional => 1,
 624                                                      },
 625                                         },
 626                              );
 627     my ($warnings) = globify_scalar(exists $param{warnings}?$param{warnings}:undef);
 628     my ($debug)    = globify_scalar(exists $param{debug}   ?$param{debug}   :undef);
 629
 630     my @packages = grep {defined $_ and length $_ } make_list($param{package});
 631     my @archs    = grep {defined $_ } make_list ($param{arch});
 632     if (not @archs) {
 633         push @archs, '';
 634     }
 635     if (not exists $param{source_version_cache}) {
 636         $param{source_version_cache} = \%_sourceversioncache;
 637     }
 638     if (grep {/,/} make_list($param{package})) {
 639         croak "Package names contain ,; split on /,/ and call make_source_versions with an arrayref of packages"
 640     }
 641     my %sourceversions;
 642     for my $version (make_list($param{versions})) {
 643         if ($version =~ m{(.+)/([^/]+)$}) {
 644             # Already a source version.
 645             $sourceversions{$version} = 1;
 646             next unless exists $param{warnings};
 647             # check to see if this source version is even possible
 648             my @bin_versions = sourcetobinary($1,$2);
 649             if (not @bin_versions or
 650                 @{$bin_versions[0]} != 3) {
 651                 print {$warnings} "The source $1 and version $2 do not appear to match any binary packages\n";
 652             }
 653         } else {
 654             if (not @packages) {
 655                 croak "You must provide at least one package if the versions are not fully qualified";
 656             }
 657             for my $pkg (@packages) {
 658                 if ($pkg =~ /^src:(.+)/) {
 659                     $sourceversions{"$1/$version"} = 1;
 660                     next unless exists $param{warnings};
 661                     # check to see if this source version is even possible
 662                     my @bin_versions = sourcetobinary($1,$version);
 663                     if (not @bin_versions or
 664                         @{$bin_versions[0]} != 3) {
 665                         print {$warnings} "The source '$1' and version '$version' do not appear to match any binary packages\n";
 666                     }
 667                     next;
 668                 }
 669                 for my $arch (@archs) {
 670                     my $cachearch = (defined $arch) ? $arch : '';
 671                     my $cachekey = "$pkg/$cachearch/$version";
 672                     if (exists($param{source_version_cache}{$cachekey})) {
 673                         for my $v (@{$param{source_version_cache}{$cachekey}}) {
 674                             $sourceversions{$v} = 1;
 675                         }
 676                         next;
 677                     }
 678                     elsif ($param{guess_source} and
 679                            exists$param{source_version_cache}{$cachekey.'/guess'}) {
 680                         for my $v (@{$param{source_version_cache}{$cachekey.'/guess'}}) {
 681                             $sourceversions{$v} = 1;
 682                         }
 683                         next;
 684                     }
 685                     my @srcinfo = binary_to_source(binary => $pkg,
 686                                                    version => $version,
 687                                                    length($arch)?(arch    => $arch):());
 688                     if (not @srcinfo) {
 689                         # We don't have explicit information about the
 690                         # binary-to-source mapping for this version
 691                         # (yet).
 692                         print {$warnings} "There is no source info for the package '$pkg' at version '$version' with architecture '$arch'\n";
 693                         if ($param{guess_source}) {
 694                             # Lets guess it
 695                             my $pkgsrc = getpkgsrc();
 696                             if (exists $pkgsrc->{$pkg}) {
 697                                 @srcinfo = ([$pkgsrc->{$pkg}, $version]);
 698                             } elsif (getsrcpkgs($pkg)) {
 699                                 # If we're looking at a source package
 700                                 # that doesn't have a binary of the
 701                                 # same name, just try the same
 702                                 # version.
 703                                 @srcinfo = ([$pkg, $version]);
 704                             } else {
 705                                 next;
 706                             }
 707                             # store guesses in a slightly different location
 708                             $param{source_version_cache}{$cachekey.'/guess'} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
 709                         }
 710                     }
 711                     else {
 712                         # only store this if we didn't have to guess it
 713                         $param{source_version_cache}{$cachekey} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
 714                     }
 715                     $sourceversions{"$_->[0]/$_->[1]"} = 1 foreach @srcinfo;
 716                 }
 717             }
 718         }
 719     }
 720     return sort keys %sourceversions;
 721 }
 722
 723
 724
 725 1;