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                                   qw(source_to_binary),
  30                                  ],
  31                     );
  32      @EXPORT_OK = ();
  33      Exporter::export_ok_tags(qw(versions mapping));
  34      $EXPORT_TAGS{all} = [@EXPORT_OK];
  35 }
  36
  37 use Fcntl qw(O_RDONLY);
  38 use MLDBM qw(DB_File Storable);
  39 use Storable qw(dclone);
  40 use Params::Validate qw(validate_with :types);
  41 use Debbugs::Common qw(make_list globify_scalar sort_versions);
  42
  43 use List::AllUtils qw(min max uniq);
  44
  45 use IO::File;
  46
  47 $MLDBM::DumpMeth = 'portable';
  48 $MLDBM::RemoveTaint = 1;
  49
  50 =head1 NAME
  51
  52 Debbugs::Packages - debbugs binary/source package handling
  53
  54 =head1 DESCRIPTION
  55
  56 The Debbugs::Packages module provides support functions to map binary
  57 packages to their corresponding source packages and vice versa. (This makes
  58 sense for software distributions, where developers may work on a single
  59 source package which produces several binary packages for use by users; it
  60 may not make sense in other contexts.)
  61
  62 =head1 METHODS
  63
  64 =head2 getpkgsrc
  65
  66 Returns a reference to a hash of binary package names to their corresponding
  67 source package names.
  68
  69 =cut
  70
  71 our $_pkgsrc;
  72 our $_pkgcomponent;
  73 our $_srcpkg;
  74 sub getpkgsrc {
  75     return $_pkgsrc if $_pkgsrc;
  76     return {} unless defined $config{package_source} and
  77         length $config{package_source};
  78     my %pkgsrc;
  79     my %pkgcomponent;
  80     my %srcpkg;
  81
  82     my $fh = IO::File->new($config{package_source},'r')
  83         or croak("Unable to open $config{package_source} for reading: $!");
  84     while(<$fh>) {
  85         next unless m/^(\S+)\s+(\S+)\s+(\S.*\S)\s*$/;
  86         my ($bin,$cmp,$src)=($1,$2,$3);
  87         $bin = lc($bin);
  88         $pkgsrc{$bin}= $src;
  89         push @{$srcpkg{$src}}, $bin;
  90         $pkgcomponent{$bin}= $cmp;
  91     }
  92     close($fh);
  93     $_pkgsrc = \%pkgsrc;
  94     $_pkgcomponent = \%pkgcomponent;
  95     $_srcpkg = \%srcpkg;
  96     return $_pkgsrc;
  97 }
  98
  99 =head2 getpkgcomponent
 100
 101 Returns a reference to a hash of binary package names to the component of
 102 the archive containing those binary packages (e.g. "main", "contrib",
 103 "non-free").
 104
 105 =cut
 106
 107 sub getpkgcomponent {
 108     return $_pkgcomponent if $_pkgcomponent;
 109     getpkgsrc();
 110     return $_pkgcomponent;
 111 }
 112
 113 =head2 getsrcpkgs
 114
 115 Returns a list of the binary packages produced by a given source package.
 116
 117 =cut
 118
 119 sub getsrcpkgs {
 120     my $src = shift;
 121     getpkgsrc() if not defined $_srcpkg;
 122     return () if not defined $src or not exists $_srcpkg->{$src};
 123     return @{$_srcpkg->{$src}};
 124 }
 125
 126 =head2 binary_to_source
 127
 128      binary_to_source(package => 'foo',
 129                       version => '1.2.3',
 130                       arch    => 'i386');
 131
 132
 133 Turn a binary package (at optional version in optional architecture)
 134 into a single (or set) of source packages (optionally) with associated
 135 versions.
 136
 137 By default, in LIST context, returns a LIST of array refs of source
 138 package, source version pairs corresponding to the binary package(s),
 139 arch(s), and verion(s) passed.
 140
 141 In SCALAR context, only the corresponding source packages are
 142 returned, concatenated with ', ' if necessary.
 143
 144 If no source can be found, returns undef in scalar context, or the
 145 empty list in list context.
 146
 147 =over
 148
 149 =item binary -- binary package name(s) as a SCALAR or ARRAYREF
 150
 151 =item version -- binary package version(s) as a SCALAR or ARRAYREF;
 152 optional, defaults to all versions.
 153
 154 =item arch -- binary package architecture(s) as a SCALAR or ARRAYREF;
 155 optional, defaults to all architectures.
 156
 157 =item source_only -- return only the source name (forced on if in
 158 SCALAR context), defaults to false.
 159
 160 =item scalar_only -- return a scalar only (forced true if in SCALAR
 161 context, also causes source_only to be true), defaults to false.
 162
 163 =item cache -- optional HASHREF to be used to cache results of
 164 binary_to_source.
 165
 166 =back
 167
 168 =cut
 169
 170 # the two global variables below are used to tie the source maps; we
 171 # probably should be retying them in long lived processes.
 172 our %_binarytosource;
 173 sub _tie_binarytosource {
 174     if (not tied %_binarytosource) {
 175         tie %_binarytosource, MLDBM => $config{binary_source_map}, O_RDONLY or
 176             die "Unable to open $config{binary_source_map} for reading";
 177     }
 178 }
 179 our %_sourcetobinary;
 180 sub _tie_sourcetobinary {
 181     if (not tied %_sourcetobinary) {
 182         tie %_sourcetobinary, MLDBM => $config{source_binary_map}, O_RDONLY or
 183             die "Unable to open $config{source_binary_map} for reading";
 184     }
 185 }
 186 sub binary_to_source{
 187     my %param = validate_with(params => \@_,
 188                               spec   => {binary => {type => SCALAR|ARRAYREF,
 189                                                     },
 190                                          version => {type => SCALAR|ARRAYREF,
 191                                                      optional => 1,
 192                                                     },
 193                                          arch    => {type => SCALAR|ARRAYREF,
 194                                                      optional => 1,
 195                                                     },
 196                                          source_only => {default => 0,
 197                                                         },
 198                                          scalar_only => {default => 0,
 199                                                         },
 200                                          cache => {type => HASHREF,
 201                                                    default => {},
 202                                                   },
 203                                          schema => {type => OBJECT,
 204                                                     optional => 1,
 205                                                    },
 206                                         },
 207                              );
 208
 209     # TODO: This gets hit a lot, especially from buggyversion() - probably
 210     # need an extra cache for speed here.
 211     return () unless defined $gBinarySourceMap or defined $param{schema};
 212
 213     if ($param{scalar_only} or not wantarray) {
 214         $param{source_only} = 1;
 215         $param{scalar_only} = 1;
 216     }
 217
 218     my @source;
 219     my @binaries = grep {defined $_} make_list(exists $param{binary}?$param{binary}:[]);
 220     my @versions = grep {defined $_} make_list(exists $param{version}?$param{version}:[]);
 221     my @archs = grep {defined $_} make_list(exists $param{arch}?$param{arch}:[]);
 222     return () unless @binaries;
 223
 224     # any src:foo is source package foo with unspecified version
 225     @source = map {/^src:(.+)$/?
 226                        [$1,'']:()} @binaries;
 227     @binaries = grep {$_ !~ /^src:/} @binaries;
 228     if ($param{schema}) {
 229         if ($param{source_only}) {
 230             @source = map {$_->[0]} @source;
 231             my $src_rs = $param{schema}->resultset('SrcPkg')->
 232                 search_rs({'binpkg.pkg' => [@binaries],
 233                            @versions?('bin_vers.ver'    => [@versions]):(),
 234                            @archs?('arch.arch' => [@archs]):(),
 235                           },
 236                          {join => {'src_vers'=>
 237                                   {'bin_vers'=> ['arch','bin_pkg']}
 238                                   },
 239                           distinct => 1,
 240                          },
 241                          );
 242             push @source,
 243                 map {$_->pkg} $src_rs->all;
 244             if ($param{scalar_only}) {
 245                 return join(',',@source);
 246             }
 247             return @source;
 248
 249         }
 250         my $src_rs = $param{schema}->resultset('SrcVer')->
 251             search_rs({'bin_pkg.pkg' => [@binaries],
 252                        @versions?('bin_vers.ver' => [@versions]):(),
 253                        @archs?('arch.arch' => [@archs]):(),
 254                       },
 255                      {join => ['src_pkg',
 256                               {'bin_vers' => ['arch','binpkg']},
 257                               ],
 258                       distinct => 1,
 259                      },
 260                      );
 261         push @source,
 262             map {[$_->get_column('src_pkg.pkg'),
 263                   $_->get_column('src_ver.ver'),
 264                  ]} $src_rs->all;
 265         if (not @source and not @versions and not @archs) {
 266             $src_rs = $param{schema}->resultset('SrcPkg')->
 267                 search_rs({pkg => [@binaries]},
 268                          {distinct => 1},
 269                          );
 270             push @source,
 271                 map {[$_->pkg,
 272                      ]} $src_rs->all;
 273         }
 274         return @source;
 275     }
 276     my $cache_key = join("\1",
 277                          join("\0",@binaries),
 278                          join("\0",@versions),
 279                          join("\0",@archs),
 280                          join("\0",@param{qw(source_only scalar_only)}));
 281     if (exists $param{cache}{$cache_key}) {
 282         return $param{scalar_only} ? $param{cache}{$cache_key}[0]:
 283             @{$param{cache}{$cache_key}};
 284     }
 285     for my $binary (@binaries) {
 286         _tie_binarytosource;
 287         # avoid autovivification
 288         my $bin = $_binarytosource{$binary};
 289         next unless defined $bin;
 290         if (not @versions) {
 291             for my $ver (keys %{$bin}) {
 292                 for my $ar (keys %{$bin->{$ver}}) {
 293                     my $src = $bin->{$ver}{$ar};
 294                     next unless defined $src;
 295                     push @source,[$src->[0],$src->[1]];
 296                 }
 297             }
 298         }
 299         else {
 300             for my $version (@versions) {
 301                 next unless exists $bin->{$version};
 302                 if (exists $bin->{$version}{all}) {
 303                     push @source,dclone($bin->{$version}{all});
 304                     next;
 305                 }
 306                 my @t_archs;
 307                 if (@archs) {
 308                     @t_archs = @archs;
 309                 }
 310                 else {
 311                     @t_archs = keys %{$bin->{$version}};
 312                 }
 313                 for my $arch (@t_archs) {
 314                     push @source,dclone($bin->{$version}{$arch}) if
 315                         exists $bin->{$version}{$arch};
 316                 }
 317             }
 318         }
 319     }
 320
 321     if (not @source and not @versions and not @archs) {
 322         # ok, we haven't found any results at all. If we weren't given
 323         # a specific version and architecture, then we should try
 324         # really hard to figure out the right source
 325
 326         # if any the packages we've been given are a valid source
 327         # package name, and there's no binary of the same name (we got
 328         # here, so there isn't), return it.
 329         _tie_sourcetobinary();
 330         for my $maybe_sourcepkg (@binaries) {
 331             if (exists $_sourcetobinary{$maybe_sourcepkg}) {
 332                 push @source,[$maybe_sourcepkg,$_] for keys %{$_sourcetobinary{$maybe_sourcepkg}};
 333             }
 334         }
 335         # if @source is still empty here, it's probably a non-existant
 336         # source package, so don't return anything.
 337     }
 338
 339     my @result;
 340
 341     if ($param{source_only}) {
 342         my %uniq;
 343         for my $s (@source) {
 344             # we shouldn't need to do this, but do this temporarily to
 345             # stop the warning.
 346             next unless defined $s->[0];
 347             $uniq{$s->[0]} = 1;
 348         }
 349         @result = sort keys %uniq;
 350         if ($param{scalar_only}) {
 351             @result = join(', ',@result);
 352         }
 353     }
 354     else {
 355         my %uniq;
 356         for my $s (@source) {
 357             $uniq{$s->[0]}{$s->[1]} = 1;
 358         }
 359         for my $sn (sort keys %uniq) {
 360             push @result, [$sn, $_] for sort keys %{$uniq{$sn}};
 361         }
 362     }
 363
 364     # No $gBinarySourceMap, or it didn't have an entry for this name and
 365     # version.
 366     $param{cache}{$cache_key} = \@result;
 367     return $param{scalar_only} ? $result[0] : @result;
 368 }
 369
 370 =head2 source_to_binary
 371
 372      source_to_binary(package => 'foo',
 373                       version => '1.2.3',
 374                       arch    => 'i386');
 375
 376
 377 Turn a source package (at optional version) into a single (or set) of all binary
 378 packages (optionally) with associated versions.
 379
 380 By default, in LIST context, returns a LIST of array refs of binary package,
 381 binary version, architecture triples corresponding to the source package(s) and
 382 verion(s) passed.
 383
 384 In SCALAR context, only the corresponding binary packages are returned,
 385 concatenated with ', ' if necessary.
 386
 387 If no binaries can be found, returns undef in scalar context, or the
 388 empty list in list context.
 389
 390 =over
 391
 392 =item source -- source package name(s) as a SCALAR or ARRAYREF
 393
 394 =item version -- binary package version(s) as a SCALAR or ARRAYREF;
 395 optional, defaults to all versions.
 396
 397 =item arch -- binary package architecture(s) as a SCALAR or ARRAYREF;
 398 optional, defaults to all architectures.
 399
 400 =item binary_only -- return only the source name (forced on if in SCALAR
 401 context), defaults to false. [If in LIST context, returns a list of binary
 402 names.]
 403
 404 =item scalar_only -- return a scalar only (forced true if in SCALAR
 405 context, also causes binary_only to be true), defaults to false.
 406
 407 =item cache -- optional HASHREF to be used to cache results of
 408 binary_to_source.
 409
 410 =back
 411
 412 =cut
 413
 414 # the two global variables below are used to tie the source maps; we
 415 # probably should be retying them in long lived processes.
 416 sub source_to_binary{
 417     my %param = validate_with(params => \@_,
 418                               spec   => {source => {type => SCALAR|ARRAYREF,
 419                                                     },
 420                                          version => {type => SCALAR|ARRAYREF,
 421                                                      optional => 1,
 422                                                     },
 423                                          binary_only => {default => 0,
 424                                                         },
 425                                          scalar_only => {default => 0,
 426                                                         },
 427                                          cache => {type => HASHREF,
 428                                                    default => {},
 429                                                   },
 430                                          schema => {type => OBJECT,
 431                                                     optional => 1,
 432                                                    },
 433                                         },
 434                              );
 435     if (not defined $config{source_binary_map} and
 436         not defined $param{schema}
 437        ) {
 438         return ();
 439     }
 440
 441     if ($param{scalar_only} or not wantarray) {
 442         $param{binary_only} = 1;
 443         $param{scalar_only} = 1;
 444     }
 445
 446     my @binaries;
 447     my @sources = sort grep {defined $_}
 448         make_list(exists $param{source}?$param{source}:[]);
 449     my @versions = sort grep {defined $_}
 450         make_list(exists $param{version}?$param{version}:[]);
 451     return () unless @sources;
 452
 453     # any src:foo is source package foo with unspecified version
 454     @sources = map {s/^src://; $_} @sources;
 455     if ($param{schema}) {
 456         if ($param{binary_only}) {
 457             my $bin_rs = $param{schema}->resultset('BinPkg')->
 458                 search_rs({'src_pkg.pkg' => [@sources],
 459                            @versions?('src_ver.ver'    => [@versions]):(),
 460                           },
 461                          {join => {'bin_vers'=>
 462                                   {'src_ver'=> 'src_pkg'}
 463                                   },
 464                           columns => [qw(pkg)],
 465                           order_by => [qw(pkg)],
 466                           result_class => 'DBIx::Class::ResultClass::HashRefInflator',
 467                           distinct => 1,
 468                          },
 469                          );
 470             push @binaries,
 471                 map {$_->{pkg}} $bin_rs->all;
 472             if ($param{scalar_only}) {
 473                 return join(', ',@binaries);
 474             }
 475             return @binaries;
 476
 477         }
 478         my $src_rs = $param{schema}->resultset('BinVer')->
 479             search_rs({'src_pkg.pkg' => [@sources],
 480                        @versions?('src_ver.ver' => [@versions]):(),
 481                       },
 482                      {join => ['bin_pkg',
 483                                'arch',
 484                               {'src_ver' => ['src_pkg']},
 485                               ],
 486                       columns => ['src_pkg.pkg','src_ver.ver','arch.arch'],
 487                       order_by => ['src_pkg.pkg','src_ver.ver','arch.arch'],
 488                       result_class => 'DBIx::Class::ResultClass::HashRefInflator',
 489                       distinct => 1,
 490                      },
 491                      );
 492         push @binaries,
 493             map {[$_->{src_pkg}{pkg},
 494                   $_->{src_ver}{ver},
 495                   $_->{arch}{arch},
 496                  ]}
 497             $src_rs->all;
 498         if (not @binaries and not @versions) {
 499             $src_rs = $param{schema}->resultset('BinPkg')->
 500                 search_rs({pkg => [@sources]},
 501                          {join => {'bin_vers' =>
 502                                    ['arch',
 503                                    {'src_ver'=>'src_pkg'}],
 504                                    },
 505                           distinct => 1,
 506                           result_class => 'DBIx::Class::ResultClass::HashRefInflator',
 507                           columns => ['src_pkg.pkg','src_ver.ver','arch.arch'],
 508                           order_by => ['src_pkg.pkg','src_ver.ver','arch.arch'],
 509                          },
 510                          );
 511             push @binaries,
 512                 map {[$_->{src_pkg}{pkg},
 513                       $_->{src_ver}{ver},
 514                       $_->{arch}{arch},
 515                      ]} $src_rs->all;
 516         }
 517         return @binaries;
 518     }
 519     my $cache_key = join("\1",
 520                          join("\0",@sources),
 521                          join("\0",@versions),
 522                          join("\0",@param{qw(binary_only scalar_only)}));
 523     if (exists $param{cache}{$cache_key}) {
 524         return $param{scalar_only} ? $param{cache}{$cache_key}[0]:
 525             @{$param{cache}{$cache_key}};
 526     }
 527     my @return;
 528     my %binaries;
 529     if ($param{binary_only}) {
 530         for my $source (@sources) {
 531             _tie_sourcetobinary;
 532             # avoid autovivification
 533             my $src = $_sourcetobinary{$source};
 534             if (not defined $src) {
 535                 next if @versions;
 536                 _tie_binarytosource;
 537                 if (exists $_binarytosource{$source}) {
 538                     $binaries{$source} = 1;
 539                 }
 540                 next;
 541             }
 542             my @src_vers = @versions;
 543             if (not @versions) {
 544                 @src_vers = keys %{$src};
 545             }
 546             for my $ver (@src_vers) {
 547                 $binaries{$_->[0]} = 1
 548                     foreach @{$src->{$ver}//[]};
 549             }
 550         }
 551         # return if we have any results.
 552         @return = sort keys %binaries;
 553         if ($param{scalar_only}) {
 554             @return = join(', ',@return);
 555         }
 556         goto RETURN_RESULT;
 557     }
 558     for my $source (@sources) {
 559         _tie_sourcetobinary;
 560         my $src = $_sourcetobinary{$source};
 561         # there isn't a source package, so return this as a binary packages if a
 562         # version hasn't been specified
 563         if (not defined $src) {
 564             next if @versions;
 565             _tie_binarytosource;
 566             if (exists $_binarytosource{$source}) {
 567                 my $bin = $_binarytosource{$source};
 568                 for my $ver (keys %{$bin}) {
 569                     for my $arch (keys %{$bin->{$ver}}) {
 570                         $binaries{$bin}{$ver}{$arch} = 1;
 571                     }
 572                 }
 573             }
 574             next;
 575         }
 576         for my $bin_ver_archs (values %{$src}) {
 577             for my $bva (@{$bin_ver_archs}) {
 578                 $binaries{$bva->[0]}{$bva->[1]}{$bva->[2]} = 1;
 579             }
 580         }
 581     }
 582     for my $bin (sort keys %binaries) {
 583         for my $ver (sort keys %{$binaries{$bin}}) {
 584             for my $arch (sort keys %{$binaries{$bin}{$ver}}) {
 585                 push @return,
 586                     [$bin,$ver,$arch];
 587             }
 588         }
 589     }
 590 RETURN_RESULT:
 591     $param{cache}{$cache_key} = \@return;
 592     return $param{scalar_only} ? $return[0] : @return;
 593 }
 594
 595
 596 =head2 sourcetobinary
 597
 598 Returns a list of references to triplets of binary package names, versions,
 599 and architectures corresponding to a given source package name and version.
 600 If the given source package name and version cannot be found in the database
 601 but the source package name is in the unversioned package-to-source map
 602 file, then a reference to a binary package name and version pair will be
 603 returned, without the architecture.
 604
 605 =cut
 606
 607 sub sourcetobinary {
 608     my ($srcname, $srcver) = @_;
 609     _tie_sourcetobinary;
 610     # avoid autovivification
 611     my $source = $_sourcetobinary{$srcname};
 612     return () unless defined $source;
 613     if (exists $source->{$srcver}) {
 614          my $bin = $source->{$srcver};
 615          return () unless defined $bin;
 616          return @$bin;
 617     }
 618     # No $gSourceBinaryMap, or it didn't have an entry for this name and
 619     # version. Try $gPackageSource (unversioned) instead.
 620     my @srcpkgs = getsrcpkgs($srcname);
 621     return map [$_, $srcver], @srcpkgs;
 622 }
 623
 624 =head2 getversions
 625
 626 Returns versions of the package in a distribution at a specific
 627 architecture
 628
 629 =cut
 630
 631 sub getversions {
 632     my ($pkg, $dist, $arch) = @_;
 633     return get_versions(package=>$pkg,
 634                         dist => $dist,
 635                         defined $arch ? (arch => $arch):(),
 636                        );
 637 }
 638
 639
 640
 641 =head2 get_versions
 642
 643      get_versions(package=>'foopkg',
 644                   dist => 'unstable',
 645                   arch => 'i386',
 646                  );
 647
 648 Returns a list of the versions of package in the distributions and
 649 architectures listed. This routine only returns unique values.
 650
 651 =over
 652
 653 =item package -- package to return list of versions
 654
 655 =item dist -- distribution (unstable, stable, testing); can be an
 656 arrayref
 657
 658 =item arch -- architecture (i386, source, ...); can be an arrayref
 659
 660 =item time -- returns a version=>time hash at which the newest package
 661 matching this version was uploaded
 662
 663 =item source -- returns source/version instead of just versions
 664
 665 =item no_source_arch -- discards the source architecture when arch is
 666 not passed. [Used for finding the versions of binary packages only.]
 667 Defaults to 0, which does not discard the source architecture. (This
 668 may change in the future, so if you care, please code accordingly.)
 669
 670 =item return_archs -- returns a version=>[archs] hash indicating which
 671 architectures are at which versions.
 672
 673 =item largest_source_version_only -- if there is more than one source
 674 version in a particular distribution, discards all versions but the
 675 largest in that distribution. Defaults to 1, as this used to be the
 676 way that the Debian archive worked.
 677
 678 =back
 679
 680 When called in scalar context, this function will return hashrefs or
 681 arrayrefs as appropriate, in list context, it will return paired lists
 682 or unpaired lists as appropriate.
 683
 684 =cut
 685
 686 our %_versions;
 687 our %_versions_time;
 688
 689 sub get_versions{
 690      my %param = validate_with(params => \@_,
 691                                 spec   => {package => {type => SCALAR|ARRAYREF,
 692                                                       },
 693                                            dist    => {type => SCALAR|ARRAYREF,
 694                                                        default => 'unstable',
 695                                                       },
 696                                            arch    => {type => SCALAR|ARRAYREF,
 697                                                        optional => 1,
 698                                                       },
 699                                            time    => {type    => BOOLEAN,
 700                                                        default => 0,
 701                                                       },
 702                                            source  => {type    => BOOLEAN,
 703                                                        default => 0,
 704                                                       },
 705                                            no_source_arch => {type => BOOLEAN,
 706                                                               default => 0,
 707                                                              },
 708                                            return_archs => {type => BOOLEAN,
 709                                                             default => 0,
 710                                                            },
 711                                            largest_source_version_only => {type => BOOLEAN,
 712                                                                        default => 1,
 713                                                                           },
 714                                           },
 715                                );
 716      my $versions;
 717      if ($param{time}) {
 718           return () if not defined $gVersionTimeIndex;
 719           unless (tied %_versions_time) {
 720                tie %_versions_time, 'MLDBM', $gVersionTimeIndex, O_RDONLY
 721                     or die "can't open versions index $gVersionTimeIndex: $!";
 722           }
 723           $versions = \%_versions_time;
 724      }
 725      else {
 726           return () if not defined $gVersionIndex;
 727           unless (tied %_versions) {
 728                tie %_versions, 'MLDBM', $gVersionIndex, O_RDONLY
 729                     or die "can't open versions index $gVersionIndex: $!";
 730           }
 731           $versions = \%_versions;
 732      }
 733      my %versions;
 734      for my $package (make_list($param{package})) {
 735           my $source_only = 0;
 736           if ($package =~ s/^src://) {
 737                $source_only = 1;
 738           }
 739           my $version = $versions->{$package};
 740           next unless defined $version;
 741           for my $dist (make_list($param{dist})) {
 742                for my $arch (exists $param{arch}?
 743                              make_list($param{arch}):
 744                              (grep {not $param{no_source_arch} or
 745                                         $_ ne 'source'
 746                                     } $source_only?'source':keys %{$version->{$dist}})) {
 747                     next unless defined $version->{$dist}{$arch};
 748                     my @vers = ref $version->{$dist}{$arch} eq 'HASH' ?
 749                         keys %{$version->{$dist}{$arch}} :
 750                             make_list($version->{$dist}{$arch});
 751                     if ($param{largest_source_version_only} and
 752                         $arch eq 'source' and @vers > 1) {
 753                         # order the versions, then pick the biggest version number
 754                         @vers = sort_versions(@vers);
 755                         @vers = $vers[-1];
 756                     }
 757                     for my $ver (@vers) {
 758                          my $f_ver = $ver;
 759                          if ($param{source}) {
 760                               ($f_ver) = make_source_versions(package => $package,
 761                                                               arch => $arch,
 762                                                               versions => $ver);
 763                               next unless defined $f_ver;
 764                          }
 765                          if ($param{time}) {
 766                               $versions{$f_ver} = max($versions{$f_ver}||0,$version->{$dist}{$arch}{$ver});
 767                          }
 768                          else {
 769                               push @{$versions{$f_ver}},$arch;
 770                          }
 771                     }
 772                }
 773           }
 774      }
 775      if ($param{time} or $param{return_archs}) {
 776           return wantarray?%versions :\%versions;
 777      }
 778      return wantarray?keys %versions :[keys %versions];
 779 }
 780
 781
 782 =head2 makesourceversions
 783
 784      @{$cgi_var{found}} = makesourceversions($cgi_var{package},undef,@{$cgi_var{found}});
 785
 786 Canonicalize versions into source versions, which have an explicitly
 787 named source package. This is used to cope with source packages whose
 788 names have changed during their history, and with cases where source
 789 version numbers differ from binary version numbers.
 790
 791 =cut
 792
 793 our %_sourceversioncache = ();
 794 sub makesourceversions {
 795     my ($package,$arch,@versions) = @_;
 796     die "Package $package is multiple packages; split on , and call makesourceversions multiple times"
 797          if $package =~ /,/;
 798     return make_source_versions(package => $package,
 799                                 (defined $arch)?(arch => $arch):(),
 800                                 versions => \@versions
 801                                );
 802 }
 803
 804 =head2 make_source_versions
 805
 806      make_source_versions(package => 'foo',
 807                           arch    => 'source',
 808                           versions => '0.1.1',
 809                           guess_source => 1,
 810                           warnings => \$warnings,
 811                          );
 812
 813 An extended version of makesourceversions (which calls this function
 814 internally) that allows for multiple packages, architectures, and
 815 outputs warnings and debugging information to provided SCALARREFs or
 816 HANDLEs.
 817
 818 The guess_source option determines whether the source package is
 819 guessed at if there is no obviously correct package. Things that use
 820 this function for non-transient output should set this to false,
 821 things that use it for transient output can set this to true.
 822 Currently it defaults to true, but that is not a sane option.
 823
 824
 825 =cut
 826
 827 sub make_source_versions {
 828     my %param = validate_with(params => \@_,
 829                               spec   => {package => {type => SCALAR|ARRAYREF,
 830                                                     },
 831                                          arch    => {type => SCALAR|ARRAYREF|UNDEF,
 832                                                      default => ''
 833                                                     },
 834                                          versions => {type => SCALAR|ARRAYREF,
 835                                                       default => [],
 836                                                      },
 837                                          guess_source => {type => BOOLEAN,
 838                                                           default => 1,
 839                                                          },
 840                                          source_version_cache => {type => HASHREF,
 841                                                                   optional => 1,
 842                                                                  },
 843                                          debug    => {type => SCALARREF|HANDLE,
 844                                                       optional => 1,
 845                                                      },
 846                                          warnings => {type => SCALARREF|HANDLE,
 847                                                       optional => 1,
 848                                                      },
 849                                         },
 850                              );
 851     my ($warnings) = globify_scalar(exists $param{warnings}?$param{warnings}:undef);
 852
 853     my @packages = grep {defined $_ and length $_ } make_list($param{package});
 854     my @archs    = grep {defined $_ } make_list ($param{arch});
 855     if (not @archs) {
 856         push @archs, '';
 857     }
 858     if (not exists $param{source_version_cache}) {
 859         $param{source_version_cache} = \%_sourceversioncache;
 860     }
 861     if (grep {/,/} make_list($param{package})) {
 862         croak "Package names contain ,; split on /,/ and call make_source_versions with an arrayref of packages"
 863     }
 864     my %sourceversions;
 865     for my $version (make_list($param{versions})) {
 866         if ($version =~ m{(.+)/([^/]+)$}) {
 867             # Already a source version.
 868             $sourceversions{$version} = 1;
 869             next unless exists $param{warnings};
 870             # check to see if this source version is even possible
 871             my @bin_versions = sourcetobinary($1,$2);
 872             if (not @bin_versions or
 873                 @{$bin_versions[0]} != 3) {
 874                 print {$warnings} "The source $1 and version $2 do not appear to match any binary packages\n";
 875             }
 876         } else {
 877             if (not @packages) {
 878                 croak "You must provide at least one package if the versions are not fully qualified";
 879             }
 880             for my $pkg (@packages) {
 881                 if ($pkg =~ /^src:(.+)/) {
 882                     $sourceversions{"$1/$version"} = 1;
 883                     next unless exists $param{warnings};
 884                     # check to see if this source version is even possible
 885                     my @bin_versions = sourcetobinary($1,$version);
 886                     if (not @bin_versions or
 887                         @{$bin_versions[0]} != 3) {
 888                         print {$warnings} "The source '$1' and version '$version' do not appear to match any binary packages\n";
 889                     }
 890                     next;
 891                 }
 892                 for my $arch (@archs) {
 893                     my $cachearch = (defined $arch) ? $arch : '';
 894                     my $cachekey = "$pkg/$cachearch/$version";
 895                     if (exists($param{source_version_cache}{$cachekey})) {
 896                         for my $v (@{$param{source_version_cache}{$cachekey}}) {
 897                             $sourceversions{$v} = 1;
 898                         }
 899                         next;
 900                     }
 901                     elsif ($param{guess_source} and
 902                            exists$param{source_version_cache}{$cachekey.'/guess'}) {
 903                         for my $v (@{$param{source_version_cache}{$cachekey.'/guess'}}) {
 904                             $sourceversions{$v} = 1;
 905                         }
 906                         next;
 907                     }
 908                     my @srcinfo = binary_to_source(binary => $pkg,
 909                                                    version => $version,
 910                                                    length($arch)?(arch    => $arch):());
 911                     if (not @srcinfo) {
 912                         # We don't have explicit information about the
 913                         # binary-to-source mapping for this version
 914                         # (yet).
 915                         print {$warnings} "There is no source info for the package '$pkg' at version '$version' with architecture '$arch'\n";
 916                         if ($param{guess_source}) {
 917                             # Lets guess it
 918                             my $pkgsrc = getpkgsrc();
 919                             if (exists $pkgsrc->{$pkg}) {
 920                                 @srcinfo = ([$pkgsrc->{$pkg}, $version]);
 921                             } elsif (getsrcpkgs($pkg)) {
 922                                 # If we're looking at a source package
 923                                 # that doesn't have a binary of the
 924                                 # same name, just try the same
 925                                 # version.
 926                                 @srcinfo = ([$pkg, $version]);
 927                             } else {
 928                                 next;
 929                             }
 930                             # store guesses in a slightly different location
 931                             $param{source_version_cache}{$cachekey.'/guess'} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
 932                         }
 933                     }
 934                     else {
 935                         # only store this if we didn't have to guess it
 936                         $param{source_version_cache}{$cachekey} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
 937                     }
 938                     $sourceversions{"$_->[0]/$_->[1]"} = 1 foreach @srcinfo;
 939                 }
 940             }
 941         }
 942     }
 943     return sort keys %sourceversions;
 944 }
 945
 946
 947
 948 1;