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          use Data::Printer;
 759          p @src_packages;
 760          my %return;
 761          if (@src_packages) {
 762              my $src_rs = $s->resultset('SrcVer')->
 763                  search({'src_pkg.pkg'=>[@src_packages],
 764                          -or => {'suite.codename' => [make_list($param{dist})],
 765                                  'suite.suite_name' => [make_list($param{dist})],
 766                                 }
 767                         },
 768                        {join => ['src_pkg',
 769                                 {
 770                                  src_associations=>'suite'},
 771                                 ],
 772                         '+select' => [qw(src_pkg.pkg),
 773                                       qw(suite.codename),
 774                                       qw(src_associations.modified),
 775                                       q(CONCAT(src_pkg.pkg,'/',me.ver))],
 776                         '+as' => ['src_pkg_name','codename',
 777                                   'modified_time',
 778                                   qw(src_pkg_ver)],
 779                         result_class => 'DBIx::Class::ResultClass::HashRefInflator',
 780                         order_by => {-desc => 'me.ver'},
 781                        },
 782                        );
 783              my %completed_dists;
 784              for my $src ($src_rs->all()) {
 785                  my $val = 'source';
 786                  if ($param{time}) {
 787                      $val = DateTime::Format::Pg->
 788                          parse_datetime($src->{modified_time})->
 789                          epoch();
 790                  }
 791                  if ($param{largest_source_version_only}) {
 792                      next if $completed_dists{$src->{codename}};
 793                      $completed_dists{$src->{codename}} = 1;
 794                  }
 795                  if ($param{source}) {
 796                      $return{$src->{src_pkg_ver}} = $val;
 797                  } else {
 798                      $return{$src->{ver}} = $val;
 799                  }
 800              }
 801          }
 802          if (@bin_packages) {
 803              my $bin_rs = $s->resultset('BinVer')->
 804                  search({'bin_pkg.pkg' => [@bin_packages],
 805                          -or => {'suite.codename' => [make_list($param{dist})],
 806                                  'suite.suite_name' => [make_list($param{dist})],
 807                                 },
 808                         },
 809                        {join => ['bin_pkg',
 810                                 {
 811                                  'src_ver'=>'src_pkg'},
 812                                 {
 813                                  bin_associations => 'suite'},
 814                                  'arch',
 815                                 ],
 816                         '+select' => [qw(bin_pkg.pkg arch.arch suite.codename),
 817                                       qw(bin_associations.modified),
 818                                       qw(src_pkg.pkg),q(CONCAT(src_pkg.pkg,'/',me.ver)),
 819                                      ],
 820                         '+as' => ['bin_pkg','arch','codename',
 821                                   'modified_time',
 822                                   'src_pkg_name','src_pkg_ver'],
 823                         result_class => 'DBIx::Class::ResultClass::HashRefInflator',
 824                         order_by => {-desc => 'src_ver.ver'},
 825                        });
 826              if (exists $param{arch}) {
 827                  $bin_rs =
 828                      $bin_rs->search({'arch.arch' => [make_list($param{arch})]},
 829                                     {
 830                                      join => 'arch'}
 831                                     );
 832              }
 833              my %completed_dists;
 834              for my $bin ($bin_rs->all()) {
 835                  my $key = $bin->{ver};
 836                  if ($param{source}) {
 837                      $key = $bin->{src_pkg_ver};
 838                  }
 839                  my $val = $bin->{arch};
 840                  if ($param{time}) {
 841                      $val = DateTime::Format::Pg->
 842                          parse_datetime($bin->{modified_time})->
 843                          epoch();
 844                  }
 845                  if ($param{largest_source_version_only}) {
 846                      if ($completed_dists{$bin->{codename}} and not
 847                          exists $return{$key}) {
 848                          next;
 849                      }
 850                      $completed_dists{$bin->{codename}} = 1;
 851                  }
 852                  push @{$return{$key}},
 853                      $val;
 854              }
 855          }
 856          if ($param{return_archs}) {
 857              if ($param{time} or $param{return_archs}) {
 858                  return wantarray?%return :\%return;
 859              }
 860              return wantarray?keys %return :[keys %return];
 861          }
 862      }
 863      my $versions;
 864      if ($param{time}) {
 865           return () if not defined $gVersionTimeIndex;
 866           unless (tied %_versions_time) {
 867                tie %_versions_time, 'MLDBM', $gVersionTimeIndex, O_RDONLY
 868                     or die "can't open versions index $gVersionTimeIndex: $!";
 869           }
 870           $versions = \%_versions_time;
 871      }
 872      else {
 873           return () if not defined $gVersionIndex;
 874           unless (tied %_versions) {
 875                tie %_versions, 'MLDBM', $gVersionIndex, O_RDONLY
 876                     or die "can't open versions index $gVersionIndex: $!";
 877           }
 878           $versions = \%_versions;
 879      }
 880      my %versions;
 881      for my $package (make_list($param{package})) {
 882           my $source_only = 0;
 883           if ($package =~ s/^src://) {
 884                $source_only = 1;
 885           }
 886           my $version = $versions->{$package};
 887           next unless defined $version;
 888           for my $dist (make_list($param{dist})) {
 889                for my $arch (exists $param{arch}?
 890                              make_list($param{arch}):
 891                              (grep {not $param{no_source_arch} or
 892                                         $_ ne 'source'
 893                                     } $source_only?'source':keys %{$version->{$dist}})) {
 894                     next unless defined $version->{$dist}{$arch};
 895                     my @vers = ref $version->{$dist}{$arch} eq 'HASH' ?
 896                         keys %{$version->{$dist}{$arch}} :
 897                             make_list($version->{$dist}{$arch});
 898                     if ($param{largest_source_version_only} and
 899                         $arch eq 'source' and @vers > 1) {
 900                         # order the versions, then pick the biggest version number
 901                         @vers = sort_versions(@vers);
 902                         @vers = $vers[-1];
 903                     }
 904                     for my $ver (@vers) {
 905                          my $f_ver = $ver;
 906                          if ($param{source}) {
 907                               ($f_ver) = make_source_versions(package => $package,
 908                                                               arch => $arch,
 909                                                               versions => $ver);
 910                               next unless defined $f_ver;
 911                          }
 912                          if ($param{time}) {
 913                               $versions{$f_ver} = max($versions{$f_ver}||0,$version->{$dist}{$arch}{$ver});
 914                          }
 915                          else {
 916                               push @{$versions{$f_ver}},$arch;
 917                          }
 918                     }
 919                }
 920           }
 921      }
 922      if ($param{time} or $param{return_archs}) {
 923           return wantarray?%versions :\%versions;
 924      }
 925      return wantarray?keys %versions :[keys %versions];
 926 }
 927
 928
 929 =head2 makesourceversions
 930
 931      @{$cgi_var{found}} = makesourceversions($cgi_var{package},undef,@{$cgi_var{found}});
 932
 933 Canonicalize versions into source versions, which have an explicitly
 934 named source package. This is used to cope with source packages whose
 935 names have changed during their history, and with cases where source
 936 version numbers differ from binary version numbers.
 937
 938 =cut
 939
 940 our %_sourceversioncache = ();
 941 sub makesourceversions {
 942     my ($package,$arch,@versions) = @_;
 943     die "Package $package is multiple packages; split on , and call makesourceversions multiple times"
 944          if $package =~ /,/;
 945     return make_source_versions(package => $package,
 946                                 (defined $arch)?(arch => $arch):(),
 947                                 versions => \@versions
 948                                );
 949 }
 950
 951 =head2 make_source_versions
 952
 953      make_source_versions(package => 'foo',
 954                           arch    => 'source',
 955                           versions => '0.1.1',
 956                           guess_source => 1,
 957                           warnings => \$warnings,
 958                          );
 959
 960 An extended version of makesourceversions (which calls this function
 961 internally) that allows for multiple packages, architectures, and
 962 outputs warnings and debugging information to provided SCALARREFs or
 963 HANDLEs.
 964
 965 The guess_source option determines whether the source package is
 966 guessed at if there is no obviously correct package. Things that use
 967 this function for non-transient output should set this to false,
 968 things that use it for transient output can set this to true.
 969 Currently it defaults to true, but that is not a sane option.
 970
 971
 972 =cut
 973
 974 sub make_source_versions {
 975     my %param = validate_with(params => \@_,
 976                               spec   => {package => {type => SCALAR|ARRAYREF,
 977                                                     },
 978                                          arch    => {type => SCALAR|ARRAYREF|UNDEF,
 979                                                      default => ''
 980                                                     },
 981                                          versions => {type => SCALAR|ARRAYREF,
 982                                                       default => [],
 983                                                      },
 984                                          guess_source => {type => BOOLEAN,
 985                                                           default => 1,
 986                                                          },
 987                                          source_version_cache => {type => HASHREF,
 988                                                                   optional => 1,
 989                                                                  },
 990                                          debug    => {type => SCALARREF|HANDLE,
 991                                                       optional => 1,
 992                                                      },
 993                                          warnings => {type => SCALARREF|HANDLE,
 994                                                       optional => 1,
 995                                                      },
 996                                          schema => {type => OBJECT,
 997                                                     optional => 1,
 998                                                    },
 999                                         },
1000                              );
1001     my ($warnings) = globify_scalar(exists $param{warnings}?$param{warnings}:undef);
1002
1003     my @packages = grep {defined $_ and length $_ } make_list($param{package});
1004     my @archs    = grep {defined $_ } make_list ($param{arch});
1005     if (not @archs) {
1006         push @archs, '';
1007     }
1008     if (not exists $param{source_version_cache}) {
1009         $param{source_version_cache} = \%_sourceversioncache;
1010     }
1011     if (grep {/,/} make_list($param{package})) {
1012         croak "Package names contain ,; split on /,/ and call make_source_versions with an arrayref of packages"
1013     }
1014     my %sourceversions;
1015     for my $version (make_list($param{versions})) {
1016         if ($version =~ m{(.+)/([^/]+)$}) {
1017             # Already a source version.
1018             $sourceversions{$version} = 1;
1019             next unless exists $param{warnings};
1020             # check to see if this source version is even possible
1021             my @bin_versions = sourcetobinary($1,$2);
1022             if (not @bin_versions or
1023                 @{$bin_versions[0]} != 3) {
1024                 print {$warnings} "The source $1 and version $2 do not appear to match any binary packages\n";
1025             }
1026         } else {
1027             if (not @packages) {
1028                 croak "You must provide at least one package if the versions are not fully qualified";
1029             }
1030             for my $pkg (@packages) {
1031                 if ($pkg =~ /^src:(.+)/) {
1032                     $sourceversions{"$1/$version"} = 1;
1033                     next unless exists $param{warnings};
1034                     # check to see if this source version is even possible
1035                     my @bin_versions = sourcetobinary($1,$version);
1036                     if (not @bin_versions or
1037                         @{$bin_versions[0]} != 3) {
1038                         print {$warnings} "The source '$1' and version '$version' do not appear to match any binary packages\n";
1039                     }
1040                     next;
1041                 }
1042                 for my $arch (@archs) {
1043                     my $cachearch = (defined $arch) ? $arch : '';
1044                     my $cachekey = "$pkg/$cachearch/$version";
1045                     if (exists($param{source_version_cache}{$cachekey})) {
1046                         for my $v (@{$param{source_version_cache}{$cachekey}}) {
1047                             $sourceversions{$v} = 1;
1048                         }
1049                         next;
1050                     }
1051                     elsif ($param{guess_source} and
1052                            exists$param{source_version_cache}{$cachekey.'/guess'}) {
1053                         for my $v (@{$param{source_version_cache}{$cachekey.'/guess'}}) {
1054                             $sourceversions{$v} = 1;
1055                         }
1056                         next;
1057                     }
1058                     my @srcinfo = binary_to_source(binary => $pkg,
1059                                                    version => $version,
1060                                                    length($arch)?(arch    => $arch):());
1061                     if (not @srcinfo) {
1062                         # We don't have explicit information about the
1063                         # binary-to-source mapping for this version
1064                         # (yet).
1065                         print {$warnings} "There is no source info for the package '$pkg' at version '$version' with architecture '$arch'\n";
1066                         if ($param{guess_source}) {
1067                             # Lets guess it
1068                             my $pkgsrc = getpkgsrc();
1069                             if (exists $pkgsrc->{$pkg}) {
1070                                 @srcinfo = ([$pkgsrc->{$pkg}, $version]);
1071                             } elsif (getsrcpkgs($pkg)) {
1072                                 # If we're looking at a source package
1073                                 # that doesn't have a binary of the
1074                                 # same name, just try the same
1075                                 # version.
1076                                 @srcinfo = ([$pkg, $version]);
1077                             } else {
1078                                 next;
1079                             }
1080                             # store guesses in a slightly different location
1081                             $param{source_version_cache}{$cachekey.'/guess'} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
1082                         }
1083                     }
1084                     else {
1085                         # only store this if we didn't have to guess it
1086                         $param{source_version_cache}{$cachekey} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
1087                     }
1088                     $sourceversions{"$_->[0]/$_->[1]"} = 1 foreach @srcinfo;
1089                 }
1090             }
1091         }
1092     }
1093     return sort keys %sourceversions;
1094 }
1095
1096
1097
1098 1;