use warnings;
use strict;
-use Debbugs::Config qw(:config :globals);
-
use base qw(Exporter);
use vars qw($VERSION @EXPORT_OK %EXPORT_TAGS @EXPORT);
+use Carp;
+
+use Debbugs::Config qw(:config :globals);
+
BEGIN {
$VERSION = 1.00;
@EXPORT = ();
- %EXPORT_TAGS = (versions => [qw(getversions get_versions)],
+ %EXPORT_TAGS = (versions => [qw(getversions get_versions make_source_versions)],
mapping => [qw(getpkgsrc getpkgcomponent getsrcpkgs),
qw(binarytosource sourcetobinary makesourceversions)
],
use MLDBM qw(DB_File Storable);
use Storable qw(dclone);
use Params::Validate qw(validate_with :types);
-use Debbugs::Common qw(make_list);
+use Debbugs::Common qw(make_list globify_scalar);
use List::Util qw(min max);
+use IO::File;
+
$MLDBM::DumpMeth = 'portable';
$MLDBM::RemoveTaint = 1;
=head1 METHODS
-=over 8
-
-=item getpkgsrc
+=head2 getpkgsrc
Returns a reference to a hash of binary package names to their corresponding
source package names.
my %pkgcomponent;
my %srcpkg;
- open(MM,"$Debbugs::Packages::gPackageSource")
- or die("open $Debbugs::Packages::gPackageSource: $!");
- while(<MM>) {
+ my $fh = IO::File->new($config{package_source},'r')
+ or die("Unable to open $config{package_source} for reading: $!");
+ while(<$fh>) {
next unless m/^(\S+)\s+(\S+)\s+(\S.*\S)\s*$/;
my ($bin,$cmp,$src)=($1,$2,$3);
- $bin =~ y/A-Z/a-z/;
+ $bin = lc($bin);
$pkgsrc{$bin}= $src;
push @{$srcpkg{$src}}, $bin;
$pkgcomponent{$bin}= $cmp;
}
- close(MM);
+ close($fh);
$_pkgsrc = \%pkgsrc;
$_pkgcomponent = \%pkgcomponent;
$_srcpkg = \%srcpkg;
return $_pkgsrc;
}
-=item getpkgcomponent
+=head2 getpkgcomponent
Returns a reference to a hash of binary package names to the component of
the archive containing those binary packages (e.g. "main", "contrib",
return $_pkgcomponent;
}
-=item getsrcpkgs
+=head2 getsrcpkgs
Returns a list of the binary packages produced by a given source package.
return @{$_srcpkg->{$src}};
}
-=item binarytosource
+=head2 binarytosource
Returns a reference to the source package name and version pair
-corresponding to a given binary package name, version, and architecture. If
-undef is passed as the architecture, returns a list of references to all
-possible pairs of source package names and versions for all architectures,
-with any duplicates removed.
+corresponding to a given binary package name, version, and architecture.
+
+If undef is passed as the architecture, returns a list of references
+to all possible pairs of source package names and versions for all
+architectures, with any duplicates removed.
+
+If the binary version is not passed either, returns a list of possible
+source package names for all architectures at all versions, with any
+duplicates removed.
=cut
my $binary = $_binarytosource{$binname};
return () unless defined $binary;
my %binary = %{$binary};
- if (exists $binary{$binver}) {
+ if (not defined $binver) {
+ my %uniq;
+ for my $ver (keys %binary) {
+ for my $ar (keys %{$binary{$ver}}) {
+ my $src = $binary{$ver}{$ar};
+ next unless defined $src;
+ $uniq{$src->[0]} = 1;
+ }
+ }
+ return keys %uniq;
+ }
+ elsif (exists $binary{$binver}) {
if (defined $binarch) {
my $src = $binary{$binver}{$binarch};
+ if (not defined $src and exists $binary{$binver}{all}) {
+ $src = $binary{$binver}{all};
+ }
return () unless defined $src; # not on this arch
# Copy the data to avoid tiedness problems.
return dclone($src);
return ();
}
-=item sourcetobinary
+=head2 sourcetobinary
Returns a list of references to triplets of binary package names, versions,
and architectures corresponding to a given source package name and version.
# avoid autovivification
my $source = $_sourcetobinary{$srcname};
return () unless defined $source;
- my %source = %{$source};
- if (exists $source{$srcver}) {
- my $bin = $source{$srcver};
+ if (exists $source->{$srcver}) {
+ my $bin = $source->{$srcver};
return () unless defined $bin;
return @$bin;
}
return map [$_, $srcver], @srcpkgs;
}
-=item getversions
+=head2 getversions
Returns versions of the package in a distribution at a specific
architecture
=head2 get_versions
- get_version(package=>'foopkg',
- dist => 'unstable',
- arch => 'i386',
- );
+ get_versions(package=>'foopkg',
+ dist => 'unstable',
+ arch => 'i386',
+ );
Returns a list of the versions of package in the distributions and
architectures listed. This routine only returns unique values.
Defaults to 0, which does not discard the source architecture. (This
may change in the future, so if you care, please code accordingly.)
+=item return_archs -- returns a version=>[archs] hash indicating which
+architectures are at which versions.
+
=back
+When called in scalar context, this function will return hashrefs or
+arrayrefs as appropriate, in list context, it will return paired lists
+or unpaired lists as appropriate.
+
=cut
our %_versions;
no_source_arch => {type => BOOLEAN,
default => 0,
},
+ return_archs => {type => BOOLEAN,
+ default => 0,
+ },
},
);
my $versions;
for my $arch (exists $param{arch}?
make_list($param{arch}):
(grep {not $param{no_source_arch} or
- $_ ne 'source'
- } keys %{$version->{$dist}})) {
+ $_ ne 'source'
+ } keys %{$version->{$dist}})) {
next unless defined $version->{$dist}{$arch};
for my $ver (ref $version->{$dist}{$arch} ?
keys %{$version->{$dist}{$arch}} :
) {
my $f_ver = $ver;
if ($param{source}) {
- ($f_ver) = makesourceversions($package,$arch,$ver);
+ ($f_ver) = make_source_versions(package => $package,
+ arch => $arch,
+ versions => $ver);
next unless defined $f_ver;
}
if ($param{time}) {
$versions{$f_ver} = max($versions{$f_ver}||0,$version->{$dist}{$arch}{$ver});
}
else {
- $versions{$f_ver} = 1;
+ push @{$versions{$f_ver}},$arch;
}
}
}
}
}
- if ($param{time}) {
- return %versions
+ if ($param{time} or $param{return_archs}) {
+ return wantarray?%versions :\%versions;
}
- return keys %versions;
+ return wantarray?keys %versions :[keys %versions];
}
-=item makesourceversions
+=head2 makesourceversions
@{$cgi_var{found}} = makesourceversions($cgi_var{package},undef,@{$cgi_var{found}});
our %_sourceversioncache = ();
sub makesourceversions {
- my $pkg = shift;
- my $arch = shift;
- my %sourceversions;
- die "Package $pkg is multiple packages; split on , and call makesourceversions multiple times"
- if $pkg =~ /,/;
+ my ($package,$arch,@versions) = @_;
+ die "Package $package is multiple packages; split on , and call makesourceversions multiple times"
+ if $package =~ /,/;
+ return make_source_versions(package => $package,
+ (defined $arch)?(arch => $arch):(),
+ versions => \@versions
+ );
+}
- for my $version (@_) {
- if ($version =~ m[/]) {
+=head2 make_source_versions
+
+ make_source_versions(package => 'foo',
+ arch => 'source',
+ versions => '0.1.1',
+ guess_source => 1,
+ debug => \$debug,
+ warnings => \$warnings,
+ );
+
+An extended version of makesourceversions (which calls this function
+internally) that allows for multiple packages, architectures, and
+outputs warnings and debugging information to provided SCALARREFs or
+HANDLEs.
+
+The guess_source option determines whether the source package is
+guessed at if there is no obviously correct package. Things that use
+this function for non-transient output should set this to false,
+things that use it for transient output can set this to true.
+Currently it defaults to true, but that is not a sane option.
+
+
+=cut
+
+sub make_source_versions {
+ my %param = validate_with(params => \@_,
+ spec => {package => {type => SCALAR|ARRAYREF,
+ },
+ arch => {type => SCALAR|ARRAYREF,
+ default => ''
+ },
+ versions => {type => SCALAR|ARRAYREF,
+ default => [],
+ },
+ guess_source => {type => BOOLEAN,
+ default => 1,
+ },
+ source_version_cache => {type => HASHREF,
+ optional => 1,
+ },
+ debug => {type => SCALARREF|HANDLE,
+ optional => 1,
+ },
+ warnings => {type => SCALARREF|HANDLE,
+ optional => 1,
+ },
+ },
+ );
+ my ($warnings) = globify_scalar(exists $param{warnings}?$param{warnings}:undef);
+ my ($debug) = globify_scalar(exists $param{debug} ?$param{debug} :undef);
+
+ my @packages = grep {defined $_ and length $_ } make_list($param{package});
+ my @archs = grep {defined $_ } make_list ($param{arch});
+ if (not @archs) {
+ push @archs, '';
+ }
+ if (not exists $param{source_version_cache}) {
+ $param{source_version_cache} = \%_sourceversioncache;
+ }
+ if (grep {/,/} make_list($param{package})) {
+ croak "Package names contain ,; split on /,/ and call make_source_versions with an arrayref of packages"
+ }
+ my %sourceversions;
+ for my $version (make_list($param{versions})) {
+ if ($version =~ m{(.+)/([^/]+)$}) {
+ # check to see if this source version is even possible
+ my @bin_versions = sourcetobinary($1,$2);
+ if (not @bin_versions or
+ @{$bin_versions[0]} != 3) {
+ print {$warnings} "The source $1 and version $2 do not appear to match any binary packages\n";
+ }
# Already a source version.
$sourceversions{$version} = 1;
} else {
- my $cachearch = (defined $arch) ? $arch : '';
- my $cachekey = "$pkg/$cachearch/$version";
- if (exists($_sourceversioncache{$cachekey})) {
- for my $v (@{$_sourceversioncache{$cachekey}}) {
- $sourceversions{$v} = 1;
+ if (not @packages) {
+ croak "You must provide at least one package if the versions are not fully qualified";
+ }
+ for my $pkg (@packages) {
+ for my $arch (@archs) {
+ my $cachearch = (defined $arch) ? $arch : '';
+ my $cachekey = "$pkg/$cachearch/$version";
+ if (exists($param{source_version_cache}{$cachekey})) {
+ for my $v (@{$param{source_version_cache}{$cachekey}}) {
+ $sourceversions{$v} = 1;
+ }
+ next;
+ }
+ elsif ($param{guess_source} and
+ exists$param{source_version_cache}{$cachekey.'/guess'}) {
+ for my $v (@{$param{source_version_cache}{$cachekey}}) {
+ $sourceversions{$v} = 1;
+ }
+ next;
+ }
+ my @srcinfo = binarytosource($pkg, $version, $arch);
+ if (not @srcinfo) {
+ # We don't have explicit information about the
+ # binary-to-source mapping for this version
+ # (yet).
+ print {$warnings} "There is no source info for the package '$pkg' at version '$version' with architecture '$arch'\n";
+ if ($param{guess_source}) {
+ # Lets guess it
+ my $pkgsrc = getpkgsrc();
+ if (exists $pkgsrc->{$pkg}) {
+ @srcinfo = ([$pkgsrc->{$pkg}, $version]);
+ } elsif (getsrcpkgs($pkg)) {
+ # If we're looking at a source package
+ # that doesn't have a binary of the
+ # same name, just try the same
+ # version.
+ @srcinfo = ([$pkg, $version]);
+ } else {
+ next;
+ }
+ # store guesses in a slightly different location
+ $param{source_version_cache}{$cachekey.'/guess'} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
+ }
+ }
+ else {
+ # only store this if we didn't have to guess it
+ $param{source_version_cache}{$cachekey} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
+ }
+ $sourceversions{"$_->[0]/$_->[1]"} = 1 foreach @srcinfo;
}
- next;
- }
-
- my @srcinfo = binarytosource($pkg, $version, $arch);
- unless (@srcinfo) {
- # We don't have explicit information about the
- # binary-to-source mapping for this version (yet). Since
- # this is a CGI script and our output is transient, we can
- # get away with just looking in the unversioned map; if it's
- # wrong (as it will be when binary and source package
- # versions differ), too bad.
- my $pkgsrc = getpkgsrc();
- if (exists $pkgsrc->{$pkg}) {
- @srcinfo = ([$pkgsrc->{$pkg}, $version]);
- } elsif (getsrcpkgs($pkg)) {
- # If we're looking at a source package that doesn't have
- # a binary of the same name, just try the same version.
- @srcinfo = ([$pkg, $version]);
- } else {
- next;
- }
- }
- $sourceversions{"$_->[0]/$_->[1]"} = 1 foreach @srcinfo;
- $_sourceversioncache{$cachekey} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
+ }
}
}
-
return sort keys %sourceversions;
}
-=back
-
-=cut
-
1;