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