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({'bin_pkg.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                           columns => [qw(pkg)],
 240                           order_by => [qw(pkg)],
 241                           result_class => 'DBIx::Class::ResultClass::HashRefInflator',
 242                           distinct => 1,
 243                          },
 244                          );
 245             push @source,
 246                 map {$_->{pkg}} $src_rs->all;
 247             if ($param{scalar_only}) {
 248                 return join(',',@source);
 249             }
 250             return @source;
 251
 252         }
 253         my $src_rs = $param{schema}->resultset('SrcVer')->
 254             search_rs({'bin_pkg.pkg' => [@binaries],
 255                        @versions?('bin_vers.ver' => [@versions]):(),
 256                        @archs?('arch.arch' => [@archs]):(),
 257                       },
 258                      {join => ['src_pkg',
 259                               {'bin_vers' => ['arch','binpkg']},
 260                               ],
 261                       columns => ['src_pkg.pkg','src_ver.ver'],
 262                       result_class => 'DBIx::Class::ResultClass::HashRefInflator',
 263                       order_by => ['src_pkg.pkg','src_ver.ver'],
 264                       distinct => 1,
 265                      },
 266                      );
 267         push @source,
 268             map {[$_->{src_pkg}{pkg},
 269                   $_->{src_ver}{ver},
 270                  ]} $src_rs->all;
 271         if (not @source and not @versions and not @archs) {
 272             $src_rs = $param{schema}->resultset('SrcPkg')->
 273                 search_rs({pkg => [@binaries]},
 274                          {join => ['src_vers'],
 275                           columns => ['src_pkg.pkg','src_vers.ver'],
 276                           distinct => 1,
 277                          },
 278                          );
 279             push @source,
 280             map {[$_->{src_pkg}{pkg},
 281                   $_->{src_vers}{ver},
 282                  ]} $src_rs->all;
 283         }
 284         return @source;
 285     }
 286     my $cache_key = join("\1",
 287                          join("\0",@binaries),
 288                          join("\0",@versions),
 289                          join("\0",@archs),
 290                          join("\0",@param{qw(source_only scalar_only)}));
 291     if (exists $param{cache}{$cache_key}) {
 292         return $param{scalar_only} ? $param{cache}{$cache_key}[0]:
 293             @{$param{cache}{$cache_key}};
 294     }
 295     for my $binary (@binaries) {
 296         _tie_binarytosource;
 297         # avoid autovivification
 298         my $bin = $_binarytosource{$binary};
 299         next unless defined $bin;
 300         if (not @versions) {
 301             for my $ver (keys %{$bin}) {
 302                 for my $ar (keys %{$bin->{$ver}}) {
 303                     my $src = $bin->{$ver}{$ar};
 304                     next unless defined $src;
 305                     push @source,[$src->[0],$src->[1]];
 306                 }
 307             }
 308         }
 309         else {
 310             for my $version (@versions) {
 311                 next unless exists $bin->{$version};
 312                 if (exists $bin->{$version}{all}) {
 313                     push @source,dclone($bin->{$version}{all});
 314                     next;
 315                 }
 316                 my @t_archs;
 317                 if (@archs) {
 318                     @t_archs = @archs;
 319                 }
 320                 else {
 321                     @t_archs = keys %{$bin->{$version}};
 322                 }
 323                 for my $arch (@t_archs) {
 324                     push @source,dclone($bin->{$version}{$arch}) if
 325                         exists $bin->{$version}{$arch};
 326                 }
 327             }
 328         }
 329     }
 330
 331     if (not @source and not @versions and not @archs) {
 332         # ok, we haven't found any results at all. If we weren't given
 333         # a specific version and architecture, then we should try
 334         # really hard to figure out the right source
 335
 336         # if any the packages we've been given are a valid source
 337         # package name, and there's no binary of the same name (we got
 338         # here, so there isn't), return it.
 339         _tie_sourcetobinary();
 340         for my $maybe_sourcepkg (@binaries) {
 341             if (exists $_sourcetobinary{$maybe_sourcepkg}) {
 342                 push @source,[$maybe_sourcepkg,$_] for keys %{$_sourcetobinary{$maybe_sourcepkg}};
 343             }
 344         }
 345         # if @source is still empty here, it's probably a non-existant
 346         # source package, so don't return anything.
 347     }
 348
 349     my @result;
 350
 351     if ($param{source_only}) {
 352         my %uniq;
 353         for my $s (@source) {
 354             # we shouldn't need to do this, but do this temporarily to
 355             # stop the warning.
 356             next unless defined $s->[0];
 357             $uniq{$s->[0]} = 1;
 358         }
 359         @result = sort keys %uniq;
 360         if ($param{scalar_only}) {
 361             @result = join(', ',@result);
 362         }
 363     }
 364     else {
 365         my %uniq;
 366         for my $s (@source) {
 367             $uniq{$s->[0]}{$s->[1]} = 1;
 368         }
 369         for my $sn (sort keys %uniq) {
 370             push @result, [$sn, $_] for sort keys %{$uniq{$sn}};
 371         }
 372     }
 373
 374     # No $gBinarySourceMap, or it didn't have an entry for this name and
 375     # version.
 376     $param{cache}{$cache_key} = \@result;
 377     return $param{scalar_only} ? $result[0] : @result;
 378 }
 379
 380 =head2 source_to_binary
 381
 382      source_to_binary(package => 'foo',
 383                       version => '1.2.3',
 384                       arch    => 'i386');
 385
 386
 387 Turn a source package (at optional version) into a single (or set) of all binary
 388 packages (optionally) with associated versions.
 389
 390 By default, in LIST context, returns a LIST of array refs of binary package,
 391 binary version, architecture triples corresponding to the source package(s) and
 392 verion(s) passed.
 393
 394 In SCALAR context, only the corresponding binary packages are returned,
 395 concatenated with ', ' if necessary.
 396
 397 If no binaries can be found, returns undef in scalar context, or the
 398 empty list in list context.
 399
 400 =over
 401
 402 =item source -- source package name(s) as a SCALAR or ARRAYREF
 403
 404 =item version -- binary package version(s) as a SCALAR or ARRAYREF;
 405 optional, defaults to all versions.
 406
 407 =item arch -- binary package architecture(s) as a SCALAR or ARRAYREF;
 408 optional, defaults to all architectures.
 409
 410 =item binary_only -- return only the source name (forced on if in SCALAR
 411 context), defaults to false. [If in LIST context, returns a list of binary
 412 names.]
 413
 414 =item scalar_only -- return a scalar only (forced true if in SCALAR
 415 context, also causes binary_only to be true), defaults to false.
 416
 417 =item cache -- optional HASHREF to be used to cache results of
 418 binary_to_source.
 419
 420 =back
 421
 422 =cut
 423
 424 # the two global variables below are used to tie the source maps; we
 425 # probably should be retying them in long lived processes.
 426 sub source_to_binary{
 427     my %param = validate_with(params => \@_,
 428                               spec   => {source => {type => SCALAR|ARRAYREF,
 429                                                     },
 430                                          version => {type => SCALAR|ARRAYREF,
 431                                                      optional => 1,
 432                                                     },
 433                                          binary_only => {default => 0,
 434                                                         },
 435                                          scalar_only => {default => 0,
 436                                                         },
 437                                          cache => {type => HASHREF,
 438                                                    default => {},
 439                                                   },
 440                                          schema => {type => OBJECT,
 441                                                     optional => 1,
 442                                                    },
 443                                         },
 444                              );
 445     if (not defined $config{source_binary_map} and
 446         not defined $param{schema}
 447        ) {
 448         return ();
 449     }
 450
 451     if ($param{scalar_only} or not wantarray) {
 452         $param{binary_only} = 1;
 453         $param{scalar_only} = 1;
 454     }
 455
 456     my @binaries;
 457     my @sources = sort grep {defined $_}
 458         make_list(exists $param{source}?$param{source}:[]);
 459     my @versions = sort grep {defined $_}
 460         make_list(exists $param{version}?$param{version}:[]);
 461     return () unless @sources;
 462
 463     # any src:foo is source package foo with unspecified version
 464     @sources = map {s/^src://; $_} @sources;
 465     if ($param{schema}) {
 466         if ($param{binary_only}) {
 467             my $bin_rs = $param{schema}->resultset('BinPkg')->
 468                 search_rs({'src_pkg.pkg' => [@sources],
 469                            @versions?('src_ver.ver'    => [@versions]):(),
 470                           },
 471                          {join => {'bin_vers'=>
 472                                   {'src_ver'=> 'src_pkg'}
 473                                   },
 474                           columns => [qw(pkg)],
 475                           order_by => [qw(pkg)],
 476                           result_class => 'DBIx::Class::ResultClass::HashRefInflator',
 477                           distinct => 1,
 478                          },
 479                          );
 480             push @binaries,
 481                 map {$_->{pkg}} $bin_rs->all;
 482             if ($param{scalar_only}) {
 483                 return join(', ',@binaries);
 484             }
 485             return @binaries;
 486
 487         }
 488         my $src_rs = $param{schema}->resultset('BinVer')->
 489             search_rs({'src_pkg.pkg' => [@sources],
 490                        @versions?('src_ver.ver' => [@versions]):(),
 491                       },
 492                      {join => ['bin_pkg',
 493                                'arch',
 494                               {'src_ver' => ['src_pkg']},
 495                               ],
 496                       columns => ['src_pkg.pkg','src_ver.ver','arch.arch'],
 497                       order_by => ['src_pkg.pkg','src_ver.ver','arch.arch'],
 498                       result_class => 'DBIx::Class::ResultClass::HashRefInflator',
 499                       distinct => 1,
 500                      },
 501                      );
 502         push @binaries,
 503             map {[$_->{src_pkg}{pkg},
 504                   $_->{src_ver}{ver},
 505                   $_->{arch}{arch},
 506                  ]}
 507             $src_rs->all;
 508         if (not @binaries and not @versions) {
 509             $src_rs = $param{schema}->resultset('BinPkg')->
 510                 search_rs({pkg => [@sources]},
 511                          {join => {'bin_vers' =>
 512                                    ['arch',
 513                                    {'src_ver'=>'src_pkg'}],
 514                                    },
 515                           distinct => 1,
 516                           result_class => 'DBIx::Class::ResultClass::HashRefInflator',
 517                           columns => ['src_pkg.pkg','src_ver.ver','arch.arch'],
 518                           order_by => ['src_pkg.pkg','src_ver.ver','arch.arch'],
 519                          },
 520                          );
 521             push @binaries,
 522                 map {[$_->{src_pkg}{pkg},
 523                       $_->{src_ver}{ver},
 524                       $_->{arch}{arch},
 525                      ]} $src_rs->all;
 526         }
 527         return @binaries;
 528     }
 529     my $cache_key = join("\1",
 530                          join("\0",@sources),
 531                          join("\0",@versions),
 532                          join("\0",@param{qw(binary_only scalar_only)}));
 533     if (exists $param{cache}{$cache_key}) {
 534         return $param{scalar_only} ? $param{cache}{$cache_key}[0]:
 535             @{$param{cache}{$cache_key}};
 536     }
 537     my @return;
 538     my %binaries;
 539     if ($param{binary_only}) {
 540         for my $source (@sources) {
 541             _tie_sourcetobinary;
 542             # avoid autovivification
 543             my $src = $_sourcetobinary{$source};
 544             if (not defined $src) {
 545                 next if @versions;
 546                 _tie_binarytosource;
 547                 if (exists $_binarytosource{$source}) {
 548                     $binaries{$source} = 1;
 549                 }
 550                 next;
 551             }
 552             my @src_vers = @versions;
 553             if (not @versions) {
 554                 @src_vers = keys %{$src};
 555             }
 556             for my $ver (@src_vers) {
 557                 $binaries{$_->[0]} = 1
 558                     foreach @{$src->{$ver}//[]};
 559             }
 560         }
 561         # return if we have any results.
 562         @return = sort keys %binaries;
 563         if ($param{scalar_only}) {
 564             @return = join(', ',@return);
 565         }
 566         goto RETURN_RESULT;
 567     }
 568     for my $source (@sources) {
 569         _tie_sourcetobinary;
 570         my $src = $_sourcetobinary{$source};
 571         # there isn't a source package, so return this as a binary packages if a
 572         # version hasn't been specified
 573         if (not defined $src) {
 574             next if @versions;
 575             _tie_binarytosource;
 576             if (exists $_binarytosource{$source}) {
 577                 my $bin = $_binarytosource{$source};
 578                 for my $ver (keys %{$bin}) {
 579                     for my $arch (keys %{$bin->{$ver}}) {
 580                         $binaries{$bin}{$ver}{$arch} = 1;
 581                     }
 582                 }
 583             }
 584             next;
 585         }
 586         for my $bin_ver_archs (values %{$src}) {
 587             for my $bva (@{$bin_ver_archs}) {
 588                 $binaries{$bva->[0]}{$bva->[1]}{$bva->[2]} = 1;
 589             }
 590         }
 591     }
 592     for my $bin (sort keys %binaries) {
 593         for my $ver (sort keys %{$binaries{$bin}}) {
 594             for my $arch (sort keys %{$binaries{$bin}{$ver}}) {
 595                 push @return,
 596                     [$bin,$ver,$arch];
 597             }
 598         }
 599     }
 600 RETURN_RESULT:
 601     $param{cache}{$cache_key} = \@return;
 602     return $param{scalar_only} ? $return[0] : @return;
 603 }
 604
 605
 606 =head2 sourcetobinary
 607
 608 Returns a list of references to triplets of binary package names, versions,
 609 and architectures corresponding to a given source package name and version.
 610 If the given source package name and version cannot be found in the database
 611 but the source package name is in the unversioned package-to-source map
 612 file, then a reference to a binary package name and version pair will be
 613 returned, without the architecture.
 614
 615 =cut
 616
 617 sub sourcetobinary {
 618     my ($srcname, $srcver) = @_;
 619     _tie_sourcetobinary;
 620     # avoid autovivification
 621     my $source = $_sourcetobinary{$srcname};
 622     return () unless defined $source;
 623     if (exists $source->{$srcver}) {
 624          my $bin = $source->{$srcver};
 625          return () unless defined $bin;
 626          return @$bin;
 627     }
 628     # No $gSourceBinaryMap, or it didn't have an entry for this name and
 629     # version. Try $gPackageSource (unversioned) instead.
 630     my @srcpkgs = getsrcpkgs($srcname);
 631     return map [$_, $srcver], @srcpkgs;
 632 }
 633
 634 =head2 getversions
 635
 636 Returns versions of the package in a distribution at a specific
 637 architecture
 638
 639 =cut
 640
 641 sub getversions {
 642     my ($pkg, $dist, $arch) = @_;
 643     return get_versions(package=>$pkg,
 644                         dist => $dist,
 645                         defined $arch ? (arch => $arch):(),
 646                        );
 647 }
 648
 649
 650
 651 =head2 get_versions
 652
 653      get_versions(package=>'foopkg',
 654                   dist => 'unstable',
 655                   arch => 'i386',
 656                  );
 657
 658 Returns a list of the versions of package in the distributions and
 659 architectures listed. This routine only returns unique values.
 660
 661 =over
 662
 663 =item package -- package to return list of versions
 664
 665 =item dist -- distribution (unstable, stable, testing); can be an
 666 arrayref
 667
 668 =item arch -- architecture (i386, source, ...); can be an arrayref
 669
 670 =item time -- returns a version=>time hash at which the newest package
 671 matching this version was uploaded
 672
 673 =item source -- returns source/version instead of just versions
 674
 675 =item no_source_arch -- discards the source architecture when arch is
 676 not passed. [Used for finding the versions of binary packages only.]
 677 Defaults to 0, which does not discard the source architecture. (This
 678 may change in the future, so if you care, please code accordingly.)
 679
 680 =item return_archs -- returns a version=>[archs] hash indicating which
 681 architectures are at which versions.
 682
 683 =item largest_source_version_only -- if there is more than one source
 684 version in a particular distribution, discards all versions but the
 685 largest in that distribution. Defaults to 1, as this used to be the
 686 way that the Debian archive worked.
 687
 688 =back
 689
 690 When called in scalar context, this function will return hashrefs or
 691 arrayrefs as appropriate, in list context, it will return paired lists
 692 or unpaired lists as appropriate.
 693
 694 =cut
 695
 696 our %_versions;
 697 our %_versions_time;
 698
 699 sub get_versions{
 700      my %param = validate_with(params => \@_,
 701                                 spec   => {package => {type => SCALAR|ARRAYREF,
 702                                                       },
 703                                            dist    => {type => SCALAR|ARRAYREF,
 704                                                        default => 'unstable',
 705                                                       },
 706                                            arch    => {type => SCALAR|ARRAYREF,
 707                                                        optional => 1,
 708                                                       },
 709                                            time    => {type    => BOOLEAN,
 710                                                        default => 0,
 711                                                       },
 712                                            source  => {type    => BOOLEAN,
 713                                                        default => 0,
 714                                                       },
 715                                            no_source_arch => {type => BOOLEAN,
 716                                                               default => 0,
 717                                                              },
 718                                            return_archs => {type => BOOLEAN,
 719                                                             default => 0,
 720                                                            },
 721                                            largest_source_version_only => {type => BOOLEAN,
 722                                                                        default => 1,
 723                                                                           },
 724                                           },
 725                                );
 726      my $versions;
 727      if ($param{time}) {
 728           return () if not defined $gVersionTimeIndex;
 729           unless (tied %_versions_time) {
 730                tie %_versions_time, 'MLDBM', $gVersionTimeIndex, O_RDONLY
 731                     or die "can't open versions index $gVersionTimeIndex: $!";
 732           }
 733           $versions = \%_versions_time;
 734      }
 735      else {
 736           return () if not defined $gVersionIndex;
 737           unless (tied %_versions) {
 738                tie %_versions, 'MLDBM', $gVersionIndex, O_RDONLY
 739                     or die "can't open versions index $gVersionIndex: $!";
 740           }
 741           $versions = \%_versions;
 742      }
 743      my %versions;
 744      for my $package (make_list($param{package})) {
 745           my $source_only = 0;
 746           if ($package =~ s/^src://) {
 747                $source_only = 1;
 748           }
 749           my $version = $versions->{$package};
 750           next unless defined $version;
 751           for my $dist (make_list($param{dist})) {
 752                for my $arch (exists $param{arch}?
 753                              make_list($param{arch}):
 754                              (grep {not $param{no_source_arch} or
 755                                         $_ ne 'source'
 756                                     } $source_only?'source':keys %{$version->{$dist}})) {
 757                     next unless defined $version->{$dist}{$arch};
 758                     my @vers = ref $version->{$dist}{$arch} eq 'HASH' ?
 759                         keys %{$version->{$dist}{$arch}} :
 760                             make_list($version->{$dist}{$arch});
 761                     if ($param{largest_source_version_only} and
 762                         $arch eq 'source' and @vers > 1) {
 763                         # order the versions, then pick the biggest version number
 764                         @vers = sort_versions(@vers);
 765                         @vers = $vers[-1];
 766                     }
 767                     for my $ver (@vers) {
 768                          my $f_ver = $ver;
 769                          if ($param{source}) {
 770                               ($f_ver) = make_source_versions(package => $package,
 771                                                               arch => $arch,
 772                                                               versions => $ver);
 773                               next unless defined $f_ver;
 774                          }
 775                          if ($param{time}) {
 776                               $versions{$f_ver} = max($versions{$f_ver}||0,$version->{$dist}{$arch}{$ver});
 777                          }
 778                          else {
 779                               push @{$versions{$f_ver}},$arch;
 780                          }
 781                     }
 782                }
 783           }
 784      }
 785      if ($param{time} or $param{return_archs}) {
 786           return wantarray?%versions :\%versions;
 787      }
 788      return wantarray?keys %versions :[keys %versions];
 789 }
 790
 791
 792 =head2 makesourceversions
 793
 794      @{$cgi_var{found}} = makesourceversions($cgi_var{package},undef,@{$cgi_var{found}});
 795
 796 Canonicalize versions into source versions, which have an explicitly
 797 named source package. This is used to cope with source packages whose
 798 names have changed during their history, and with cases where source
 799 version numbers differ from binary version numbers.
 800
 801 =cut
 802
 803 our %_sourceversioncache = ();
 804 sub makesourceversions {
 805     my ($package,$arch,@versions) = @_;
 806     die "Package $package is multiple packages; split on , and call makesourceversions multiple times"
 807          if $package =~ /,/;
 808     return make_source_versions(package => $package,
 809                                 (defined $arch)?(arch => $arch):(),
 810                                 versions => \@versions
 811                                );
 812 }
 813
 814 =head2 make_source_versions
 815
 816      make_source_versions(package => 'foo',
 817                           arch    => 'source',
 818                           versions => '0.1.1',
 819                           guess_source => 1,
 820                           warnings => \$warnings,
 821                          );
 822
 823 An extended version of makesourceversions (which calls this function
 824 internally) that allows for multiple packages, architectures, and
 825 outputs warnings and debugging information to provided SCALARREFs or
 826 HANDLEs.
 827
 828 The guess_source option determines whether the source package is
 829 guessed at if there is no obviously correct package. Things that use
 830 this function for non-transient output should set this to false,
 831 things that use it for transient output can set this to true.
 832 Currently it defaults to true, but that is not a sane option.
 833
 834
 835 =cut
 836
 837 sub make_source_versions {
 838     my %param = validate_with(params => \@_,
 839                               spec   => {package => {type => SCALAR|ARRAYREF,
 840                                                     },
 841                                          arch    => {type => SCALAR|ARRAYREF|UNDEF,
 842                                                      default => ''
 843                                                     },
 844                                          versions => {type => SCALAR|ARRAYREF,
 845                                                       default => [],
 846                                                      },
 847                                          guess_source => {type => BOOLEAN,
 848                                                           default => 1,
 849                                                          },
 850                                          source_version_cache => {type => HASHREF,
 851                                                                   optional => 1,
 852                                                                  },
 853                                          debug    => {type => SCALARREF|HANDLE,
 854                                                       optional => 1,
 855                                                      },
 856                                          warnings => {type => SCALARREF|HANDLE,
 857                                                       optional => 1,
 858                                                      },
 859                                         },
 860                              );
 861     my ($warnings) = globify_scalar(exists $param{warnings}?$param{warnings}:undef);
 862
 863     my @packages = grep {defined $_ and length $_ } make_list($param{package});
 864     my @archs    = grep {defined $_ } make_list ($param{arch});
 865     if (not @archs) {
 866         push @archs, '';
 867     }
 868     if (not exists $param{source_version_cache}) {
 869         $param{source_version_cache} = \%_sourceversioncache;
 870     }
 871     if (grep {/,/} make_list($param{package})) {
 872         croak "Package names contain ,; split on /,/ and call make_source_versions with an arrayref of packages"
 873     }
 874     my %sourceversions;
 875     for my $version (make_list($param{versions})) {
 876         if ($version =~ m{(.+)/([^/]+)$}) {
 877             # Already a source version.
 878             $sourceversions{$version} = 1;
 879             next unless exists $param{warnings};
 880             # check to see if this source version is even possible
 881             my @bin_versions = sourcetobinary($1,$2);
 882             if (not @bin_versions or
 883                 @{$bin_versions[0]} != 3) {
 884                 print {$warnings} "The source $1 and version $2 do not appear to match any binary packages\n";
 885             }
 886         } else {
 887             if (not @packages) {
 888                 croak "You must provide at least one package if the versions are not fully qualified";
 889             }
 890             for my $pkg (@packages) {
 891                 if ($pkg =~ /^src:(.+)/) {
 892                     $sourceversions{"$1/$version"} = 1;
 893                     next unless exists $param{warnings};
 894                     # check to see if this source version is even possible
 895                     my @bin_versions = sourcetobinary($1,$version);
 896                     if (not @bin_versions or
 897                         @{$bin_versions[0]} != 3) {
 898                         print {$warnings} "The source '$1' and version '$version' do not appear to match any binary packages\n";
 899                     }
 900                     next;
 901                 }
 902                 for my $arch (@archs) {
 903                     my $cachearch = (defined $arch) ? $arch : '';
 904                     my $cachekey = "$pkg/$cachearch/$version";
 905                     if (exists($param{source_version_cache}{$cachekey})) {
 906                         for my $v (@{$param{source_version_cache}{$cachekey}}) {
 907                             $sourceversions{$v} = 1;
 908                         }
 909                         next;
 910                     }
 911                     elsif ($param{guess_source} and
 912                            exists$param{source_version_cache}{$cachekey.'/guess'}) {
 913                         for my $v (@{$param{source_version_cache}{$cachekey.'/guess'}}) {
 914                             $sourceversions{$v} = 1;
 915                         }
 916                         next;
 917                     }
 918                     my @srcinfo = binary_to_source(binary => $pkg,
 919                                                    version => $version,
 920                                                    length($arch)?(arch    => $arch):());
 921                     if (not @srcinfo) {
 922                         # We don't have explicit information about the
 923                         # binary-to-source mapping for this version
 924                         # (yet).
 925                         print {$warnings} "There is no source info for the package '$pkg' at version '$version' with architecture '$arch'\n";
 926                         if ($param{guess_source}) {
 927                             # Lets guess it
 928                             my $pkgsrc = getpkgsrc();
 929                             if (exists $pkgsrc->{$pkg}) {
 930                                 @srcinfo = ([$pkgsrc->{$pkg}, $version]);
 931                             } elsif (getsrcpkgs($pkg)) {
 932                                 # If we're looking at a source package
 933                                 # that doesn't have a binary of the
 934                                 # same name, just try the same
 935                                 # version.
 936                                 @srcinfo = ([$pkg, $version]);
 937                             } else {
 938                                 next;
 939                             }
 940                             # store guesses in a slightly different location
 941                             $param{source_version_cache}{$cachekey.'/guess'} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
 942                         }
 943                     }
 944                     else {
 945                         # only store this if we didn't have to guess it
 946                         $param{source_version_cache}{$cachekey} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
 947                     }
 948                     $sourceversions{"$_->[0]/$_->[1]"} = 1 foreach @srcinfo;
 949                 }
 950             }
 951         }
 952     }
 953     return sort keys %sourceversions;
 954 }
 955
 956
 957
 958 1;