X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=Debbugs%2FPackages.pm;h=5db565d21c3e4cf4d037a63a4e1b9a1bf650eb18;hb=edbb0e4cc0bc8b35ce327e83011d8a199798dbca;hp=e423bdd019c8387477d1abfd71d0b4f9a35c7048;hpb=4dd2c3f274331284fc6ce35a88234a8a4dd3c955;p=debbugs.git diff --git a/Debbugs/Packages.pm b/Debbugs/Packages.pm index e423bdd..5db565d 100644 --- a/Debbugs/Packages.pm +++ b/Debbugs/Packages.pm @@ -12,16 +12,18 @@ package Debbugs::Packages; 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) ], @@ -35,10 +37,12 @@ use Fcntl qw(O_RDONLY); 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; @@ -56,9 +60,7 @@ may not make sense in other contexts.) =head1 METHODS -=over 8 - -=item getpkgsrc +=head2 getpkgsrc Returns a reference to a hash of binary package names to their corresponding source package names. @@ -75,24 +77,24 @@ sub getpkgsrc { my %pkgcomponent; my %srcpkg; - open(MM,"$Debbugs::Packages::gPackageSource") - or die("open $Debbugs::Packages::gPackageSource: $!"); - while() { + 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", @@ -106,7 +108,7 @@ sub getpkgcomponent { return $_pkgcomponent; } -=item getsrcpkgs +=head2 getsrcpkgs Returns a list of the binary packages produced by a given source package. @@ -119,13 +121,18 @@ sub getsrcpkgs { 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 @@ -146,9 +153,23 @@ sub binarytosource { 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); @@ -176,7 +197,7 @@ sub binarytosource { 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. @@ -201,9 +222,8 @@ sub sourcetobinary { # 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; } @@ -213,7 +233,7 @@ sub sourcetobinary { return map [$_, $srcver], @srcpkgs; } -=item getversions +=head2 getversions Returns versions of the package in a distribution at a specific architecture @@ -232,10 +252,10 @@ sub getversions { =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. @@ -254,8 +274,20 @@ matching this version was uploaded =item source -- returns source/version instead of just versions +=item no_source_arch -- discards the source architecture when arch is +not passed. [Used for finding the versions of binary packages only.] +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; @@ -263,7 +295,7 @@ our %_versions_time; sub get_versions{ my %param = validate_with(params => \@_, - spec => {package => {type => SCALAR, + spec => {package => {type => SCALAR|ARRAYREF, }, dist => {type => SCALAR|ARRAYREF, default => 'unstable', @@ -277,6 +309,12 @@ sub get_versions{ source => {type => BOOLEAN, default => 0, }, + no_source_arch => {type => BOOLEAN, + default => 0, + }, + return_archs => {type => BOOLEAN, + default => 0, + }, }, ); my $versions; @@ -303,7 +341,9 @@ sub get_versions{ for my $dist (make_list($param{dist})) { for my $arch (exists $param{arch}? make_list($param{arch}): - (keys %{$version->{$dist}})) { + (grep {not $param{no_source_arch} or + $_ ne 'source' + } keys %{$version->{$dist}})) { next unless defined $version->{$dist}{$arch}; for my $ver (ref $version->{$dist}{$arch} ? keys %{$version->{$dist}{$arch}} : @@ -311,26 +351,29 @@ sub get_versions{ ) { 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}}); @@ -343,57 +386,145 @@ version numbers differ from binary version numbers. 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;