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 dist -- list of distributions to return corresponding binary packages for
 408 as a SCALAR or ARRAYREF.
 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                                          dist => {type => SCALAR|ARRAYREF,
 434                                                   optional => 1,
 435                                                  },
 436                                          binary_only => {default => 0,
 437                                                         },
 438                                          scalar_only => {default => 0,
 439                                                         },
 440                                          cache => {type => HASHREF,
 441                                                    default => {},
 442                                                   },
 443                                          schema => {type => OBJECT,
 444                                                     optional => 1,
 445                                                    },
 446                                         },
 447                              );
 448     if (not defined $config{source_binary_map} and
 449         not defined $param{schema}
 450        ) {
 451         return ();
 452     }
 453
 454     if ($param{scalar_only} or not wantarray) {
 455         $param{binary_only} = 1;
 456         $param{scalar_only} = 1;
 457     }
 458
 459     my @binaries;
 460     my @sources = sort grep {defined $_}
 461         make_list(exists $param{source}?$param{source}:[]);
 462     my @versions = sort grep {defined $_}
 463         make_list(exists $param{version}?$param{version}:[]);
 464     return () unless @sources;
 465
 466     # any src:foo is source package foo with unspecified version
 467     @sources = map {s/^src://; $_} @sources;
 468     if ($param{schema}) {
 469         if ($param{binary_only}) {
 470             my $bin_rs = $param{schema}->resultset('BinPkg')->
 471                 search_rs({'src_pkg.pkg' => [@sources],
 472                            @versions?('src_ver.ver'    => [@versions]):(),
 473                           },
 474                          {join => {'bin_vers'=>
 475                                   {'src_ver'=> 'src_pkg'}
 476                                   },
 477                           columns => [qw(pkg)],
 478                           order_by => [qw(pkg)],
 479                           result_class => 'DBIx::Class::ResultClass::HashRefInflator',
 480                           distinct => 1,
 481                          },
 482                          );
 483             if (exists $param{dist}) {
 484                 $bin_rs = $bin_rs->
 485                     search({-or =>
 486                            {'suite.codename' => [make_list($param{dist})],
 487                             'suite.suite_name' => [make_list($param{dist})],
 488                            }},
 489                            {join => {'bin_vers' =>
 490                                     {'bin_associations' =>
 491                                      'suite'
 492                                     }},
 493                             });
 494             }
 495             push @binaries,
 496                 map {$_->{pkg}} $bin_rs->all;
 497             if ($param{scalar_only}) {
 498                 return join(', ',@binaries);
 499             }
 500             return @binaries;
 501
 502         }
 503         my $src_rs = $param{schema}->resultset('BinVer')->
 504             search_rs({'src_pkg.pkg' => [@sources],
 505                        @versions?('src_ver.ver' => [@versions]):(),
 506                       },
 507                      {join => ['bin_pkg',
 508                                'arch',
 509                               {'src_ver' => ['src_pkg']},
 510                               ],
 511                       columns => ['src_pkg.pkg','src_ver.ver','arch.arch'],
 512                       order_by => ['src_pkg.pkg','src_ver.ver','arch.arch'],
 513                       result_class => 'DBIx::Class::ResultClass::HashRefInflator',
 514                       distinct => 1,
 515                      },
 516                      );
 517         push @binaries,
 518             map {[$_->{src_pkg}{pkg},
 519                   $_->{src_ver}{ver},
 520                   $_->{arch}{arch},
 521                  ]}
 522             $src_rs->all;
 523         if (not @binaries and not @versions) {
 524             $src_rs = $param{schema}->resultset('BinPkg')->
 525                 search_rs({pkg => [@sources]},
 526                          {join => {'bin_vers' =>
 527                                    ['arch',
 528                                    {'src_ver'=>'src_pkg'}],
 529                                    },
 530                           distinct => 1,
 531                           result_class => 'DBIx::Class::ResultClass::HashRefInflator',
 532                           columns => ['src_pkg.pkg','src_ver.ver','arch.arch'],
 533                           order_by => ['src_pkg.pkg','src_ver.ver','arch.arch'],
 534                          },
 535                          );
 536             push @binaries,
 537                 map {[$_->{src_pkg}{pkg},
 538                       $_->{src_ver}{ver},
 539                       $_->{arch}{arch},
 540                      ]} $src_rs->all;
 541         }
 542         return @binaries;
 543     }
 544     my $cache_key = join("\1",
 545                          join("\0",@sources),
 546                          join("\0",@versions),
 547                          join("\0",@param{qw(binary_only scalar_only)}));
 548     if (exists $param{cache}{$cache_key}) {
 549         return $param{scalar_only} ? $param{cache}{$cache_key}[0]:
 550             @{$param{cache}{$cache_key}};
 551     }
 552     my @return;
 553     my %binaries;
 554     if ($param{binary_only}) {
 555         for my $source (@sources) {
 556             _tie_sourcetobinary;
 557             # avoid autovivification
 558             my $src = $_sourcetobinary{$source};
 559             if (not defined $src) {
 560                 next if @versions;
 561                 _tie_binarytosource;
 562                 if (exists $_binarytosource{$source}) {
 563                     $binaries{$source} = 1;
 564                 }
 565                 next;
 566             }
 567             my @src_vers = @versions;
 568             if (not @versions) {
 569                 @src_vers = keys %{$src};
 570             }
 571             for my $ver (@src_vers) {
 572                 $binaries{$_->[0]} = 1
 573                     foreach @{$src->{$ver}//[]};
 574             }
 575         }
 576         # return if we have any results.
 577         @return = sort keys %binaries;
 578         if ($param{scalar_only}) {
 579             @return = join(', ',@return);
 580         }
 581         goto RETURN_RESULT;
 582     }
 583     for my $source (@sources) {
 584         _tie_sourcetobinary;
 585         my $src = $_sourcetobinary{$source};
 586         # there isn't a source package, so return this as a binary packages if a
 587         # version hasn't been specified
 588         if (not defined $src) {
 589             next if @versions;
 590             _tie_binarytosource;
 591             if (exists $_binarytosource{$source}) {
 592                 my $bin = $_binarytosource{$source};
 593                 for my $ver (keys %{$bin}) {
 594                     for my $arch (keys %{$bin->{$ver}}) {
 595                         $binaries{$bin}{$ver}{$arch} = 1;
 596                     }
 597                 }
 598             }
 599             next;
 600         }
 601         for my $bin_ver_archs (values %{$src}) {
 602             for my $bva (@{$bin_ver_archs}) {
 603                 $binaries{$bva->[0]}{$bva->[1]}{$bva->[2]} = 1;
 604             }
 605         }
 606     }
 607     for my $bin (sort keys %binaries) {
 608         for my $ver (sort keys %{$binaries{$bin}}) {
 609             for my $arch (sort keys %{$binaries{$bin}{$ver}}) {
 610                 push @return,
 611                     [$bin,$ver,$arch];
 612             }
 613         }
 614     }
 615 RETURN_RESULT:
 616     $param{cache}{$cache_key} = \@return;
 617     return $param{scalar_only} ? $return[0] : @return;
 618 }
 619
 620
 621 =head2 sourcetobinary
 622
 623 Returns a list of references to triplets of binary package names, versions,
 624 and architectures corresponding to a given source package name and version.
 625 If the given source package name and version cannot be found in the database
 626 but the source package name is in the unversioned package-to-source map
 627 file, then a reference to a binary package name and version pair will be
 628 returned, without the architecture.
 629
 630 =cut
 631
 632 sub sourcetobinary {
 633     my ($srcname, $srcver) = @_;
 634     _tie_sourcetobinary;
 635     # avoid autovivification
 636     my $source = $_sourcetobinary{$srcname};
 637     return () unless defined $source;
 638     if (exists $source->{$srcver}) {
 639          my $bin = $source->{$srcver};
 640          return () unless defined $bin;
 641          return @$bin;
 642     }
 643     # No $gSourceBinaryMap, or it didn't have an entry for this name and
 644     # version. Try $gPackageSource (unversioned) instead.
 645     my @srcpkgs = getsrcpkgs($srcname);
 646     return map [$_, $srcver], @srcpkgs;
 647 }
 648
 649 =head2 getversions
 650
 651 Returns versions of the package in a distribution at a specific
 652 architecture
 653
 654 =cut
 655
 656 sub getversions {
 657     my ($pkg, $dist, $arch) = @_;
 658     return get_versions(package=>$pkg,
 659                         dist => $dist,
 660                         defined $arch ? (arch => $arch):(),
 661                        );
 662 }
 663
 664
 665
 666 =head2 get_versions
 667
 668      get_versions(package=>'foopkg',
 669                   dist => 'unstable',
 670                   arch => 'i386',
 671                  );
 672
 673 Returns a list of the versions of package in the distributions and
 674 architectures listed. This routine only returns unique values.
 675
 676 =over
 677
 678 =item package -- package to return list of versions
 679
 680 =item dist -- distribution (unstable, stable, testing); can be an
 681 arrayref
 682
 683 =item arch -- architecture (i386, source, ...); can be an arrayref
 684
 685 =item time -- returns a version=>time hash at which the newest package
 686 matching this version was uploaded
 687
 688 =item source -- returns source/version instead of just versions
 689
 690 =item no_source_arch -- discards the source architecture when arch is
 691 not passed. [Used for finding the versions of binary packages only.]
 692 Defaults to 0, which does not discard the source architecture. (This
 693 may change in the future, so if you care, please code accordingly.)
 694
 695 =item return_archs -- returns a version=>[archs] hash indicating which
 696 architectures are at which versions.
 697
 698 =item largest_source_version_only -- if there is more than one source
 699 version in a particular distribution, discards all versions but the
 700 largest in that distribution. Defaults to 1, as this used to be the
 701 way that the Debian archive worked.
 702
 703 =back
 704
 705 When called in scalar context, this function will return hashrefs or
 706 arrayrefs as appropriate, in list context, it will return paired lists
 707 or unpaired lists as appropriate.
 708
 709 =cut
 710
 711 our %_versions;
 712 our %_versions_time;
 713
 714 sub get_versions{
 715      my %param = validate_with(params => \@_,
 716                                 spec   => {package => {type => SCALAR|ARRAYREF,
 717                                                       },
 718                                            dist    => {type => SCALAR|ARRAYREF,
 719                                                        default => 'unstable',
 720                                                       },
 721                                            arch    => {type => SCALAR|ARRAYREF,
 722                                                        optional => 1,
 723                                                       },
 724                                            time    => {type    => BOOLEAN,
 725                                                        default => 0,
 726                                                       },
 727                                            source  => {type    => BOOLEAN,
 728                                                        default => 0,
 729                                                       },
 730                                            no_source_arch => {type => BOOLEAN,
 731                                                               default => 0,
 732                                                              },
 733                                            return_archs => {type => BOOLEAN,
 734                                                             default => 0,
 735                                                            },
 736                                            largest_source_version_only => {type => BOOLEAN,
 737                                                                        default => 1,
 738                                                                           },
 739                                           },
 740                                );
 741      my $versions;
 742      if ($param{time}) {
 743           return () if not defined $gVersionTimeIndex;
 744           unless (tied %_versions_time) {
 745                tie %_versions_time, 'MLDBM', $gVersionTimeIndex, O_RDONLY
 746                     or die "can't open versions index $gVersionTimeIndex: $!";
 747           }
 748           $versions = \%_versions_time;
 749      }
 750      else {
 751           return () if not defined $gVersionIndex;
 752           unless (tied %_versions) {
 753                tie %_versions, 'MLDBM', $gVersionIndex, O_RDONLY
 754                     or die "can't open versions index $gVersionIndex: $!";
 755           }
 756           $versions = \%_versions;
 757      }
 758      my %versions;
 759      for my $package (make_list($param{package})) {
 760           my $source_only = 0;
 761           if ($package =~ s/^src://) {
 762                $source_only = 1;
 763           }
 764           my $version = $versions->{$package};
 765           next unless defined $version;
 766           for my $dist (make_list($param{dist})) {
 767                for my $arch (exists $param{arch}?
 768                              make_list($param{arch}):
 769                              (grep {not $param{no_source_arch} or
 770                                         $_ ne 'source'
 771                                     } $source_only?'source':keys %{$version->{$dist}})) {
 772                     next unless defined $version->{$dist}{$arch};
 773                     my @vers = ref $version->{$dist}{$arch} eq 'HASH' ?
 774                         keys %{$version->{$dist}{$arch}} :
 775                             make_list($version->{$dist}{$arch});
 776                     if ($param{largest_source_version_only} and
 777                         $arch eq 'source' and @vers > 1) {
 778                         # order the versions, then pick the biggest version number
 779                         @vers = sort_versions(@vers);
 780                         @vers = $vers[-1];
 781                     }
 782                     for my $ver (@vers) {
 783                          my $f_ver = $ver;
 784                          if ($param{source}) {
 785                               ($f_ver) = make_source_versions(package => $package,
 786                                                               arch => $arch,
 787                                                               versions => $ver);
 788                               next unless defined $f_ver;
 789                          }
 790                          if ($param{time}) {
 791                               $versions{$f_ver} = max($versions{$f_ver}||0,$version->{$dist}{$arch}{$ver});
 792                          }
 793                          else {
 794                               push @{$versions{$f_ver}},$arch;
 795                          }
 796                     }
 797                }
 798           }
 799      }
 800      if ($param{time} or $param{return_archs}) {
 801           return wantarray?%versions :\%versions;
 802      }
 803      return wantarray?keys %versions :[keys %versions];
 804 }
 805
 806
 807 =head2 makesourceversions
 808
 809      @{$cgi_var{found}} = makesourceversions($cgi_var{package},undef,@{$cgi_var{found}});
 810
 811 Canonicalize versions into source versions, which have an explicitly
 812 named source package. This is used to cope with source packages whose
 813 names have changed during their history, and with cases where source
 814 version numbers differ from binary version numbers.
 815
 816 =cut
 817
 818 our %_sourceversioncache = ();
 819 sub makesourceversions {
 820     my ($package,$arch,@versions) = @_;
 821     die "Package $package is multiple packages; split on , and call makesourceversions multiple times"
 822          if $package =~ /,/;
 823     return make_source_versions(package => $package,
 824                                 (defined $arch)?(arch => $arch):(),
 825                                 versions => \@versions
 826                                );
 827 }
 828
 829 =head2 make_source_versions
 830
 831      make_source_versions(package => 'foo',
 832                           arch    => 'source',
 833                           versions => '0.1.1',
 834                           guess_source => 1,
 835                           warnings => \$warnings,
 836                          );
 837
 838 An extended version of makesourceversions (which calls this function
 839 internally) that allows for multiple packages, architectures, and
 840 outputs warnings and debugging information to provided SCALARREFs or
 841 HANDLEs.
 842
 843 The guess_source option determines whether the source package is
 844 guessed at if there is no obviously correct package. Things that use
 845 this function for non-transient output should set this to false,
 846 things that use it for transient output can set this to true.
 847 Currently it defaults to true, but that is not a sane option.
 848
 849
 850 =cut
 851
 852 sub make_source_versions {
 853     my %param = validate_with(params => \@_,
 854                               spec   => {package => {type => SCALAR|ARRAYREF,
 855                                                     },
 856                                          arch    => {type => SCALAR|ARRAYREF|UNDEF,
 857                                                      default => ''
 858                                                     },
 859                                          versions => {type => SCALAR|ARRAYREF,
 860                                                       default => [],
 861                                                      },
 862                                          guess_source => {type => BOOLEAN,
 863                                                           default => 1,
 864                                                          },
 865                                          source_version_cache => {type => HASHREF,
 866                                                                   optional => 1,
 867                                                                  },
 868                                          debug    => {type => SCALARREF|HANDLE,
 869                                                       optional => 1,
 870                                                      },
 871                                          warnings => {type => SCALARREF|HANDLE,
 872                                                       optional => 1,
 873                                                      },
 874                                         },
 875                              );
 876     my ($warnings) = globify_scalar(exists $param{warnings}?$param{warnings}:undef);
 877
 878     my @packages = grep {defined $_ and length $_ } make_list($param{package});
 879     my @archs    = grep {defined $_ } make_list ($param{arch});
 880     if (not @archs) {
 881         push @archs, '';
 882     }
 883     if (not exists $param{source_version_cache}) {
 884         $param{source_version_cache} = \%_sourceversioncache;
 885     }
 886     if (grep {/,/} make_list($param{package})) {
 887         croak "Package names contain ,; split on /,/ and call make_source_versions with an arrayref of packages"
 888     }
 889     my %sourceversions;
 890     for my $version (make_list($param{versions})) {
 891         if ($version =~ m{(.+)/([^/]+)$}) {
 892             # Already a source version.
 893             $sourceversions{$version} = 1;
 894             next unless exists $param{warnings};
 895             # check to see if this source version is even possible
 896             my @bin_versions = sourcetobinary($1,$2);
 897             if (not @bin_versions or
 898                 @{$bin_versions[0]} != 3) {
 899                 print {$warnings} "The source $1 and version $2 do not appear to match any binary packages\n";
 900             }
 901         } else {
 902             if (not @packages) {
 903                 croak "You must provide at least one package if the versions are not fully qualified";
 904             }
 905             for my $pkg (@packages) {
 906                 if ($pkg =~ /^src:(.+)/) {
 907                     $sourceversions{"$1/$version"} = 1;
 908                     next unless exists $param{warnings};
 909                     # check to see if this source version is even possible
 910                     my @bin_versions = sourcetobinary($1,$version);
 911                     if (not @bin_versions or
 912                         @{$bin_versions[0]} != 3) {
 913                         print {$warnings} "The source '$1' and version '$version' do not appear to match any binary packages\n";
 914                     }
 915                     next;
 916                 }
 917                 for my $arch (@archs) {
 918                     my $cachearch = (defined $arch) ? $arch : '';
 919                     my $cachekey = "$pkg/$cachearch/$version";
 920                     if (exists($param{source_version_cache}{$cachekey})) {
 921                         for my $v (@{$param{source_version_cache}{$cachekey}}) {
 922                             $sourceversions{$v} = 1;
 923                         }
 924                         next;
 925                     }
 926                     elsif ($param{guess_source} and
 927                            exists$param{source_version_cache}{$cachekey.'/guess'}) {
 928                         for my $v (@{$param{source_version_cache}{$cachekey.'/guess'}}) {
 929                             $sourceversions{$v} = 1;
 930                         }
 931                         next;
 932                     }
 933                     my @srcinfo = binary_to_source(binary => $pkg,
 934                                                    version => $version,
 935                                                    length($arch)?(arch    => $arch):());
 936                     if (not @srcinfo) {
 937                         # We don't have explicit information about the
 938                         # binary-to-source mapping for this version
 939                         # (yet).
 940                         print {$warnings} "There is no source info for the package '$pkg' at version '$version' with architecture '$arch'\n";
 941                         if ($param{guess_source}) {
 942                             # Lets guess it
 943                             my $pkgsrc = getpkgsrc();
 944                             if (exists $pkgsrc->{$pkg}) {
 945                                 @srcinfo = ([$pkgsrc->{$pkg}, $version]);
 946                             } elsif (getsrcpkgs($pkg)) {
 947                                 # If we're looking at a source package
 948                                 # that doesn't have a binary of the
 949                                 # same name, just try the same
 950                                 # version.
 951                                 @srcinfo = ([$pkg, $version]);
 952                             } else {
 953                                 next;
 954                             }
 955                             # store guesses in a slightly different location
 956                             $param{source_version_cache}{$cachekey.'/guess'} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
 957                         }
 958                     }
 959                     else {
 960                         # only store this if we didn't have to guess it
 961                         $param{source_version_cache}{$cachekey} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
 962                     }
 963                     $sourceversions{"$_->[0]/$_->[1]"} = 1 foreach @srcinfo;
 964                 }
 965             }
 966         }
 967     }
 968     return sort keys %sourceversions;
 969 }
 970
 971
 972
 973 1;