From: cjwatson <> Date: Sun, 24 Jul 2005 22:06:54 +0000 (-0800) Subject: [project @ 2005-07-24 15:06:54 by cjwatson] X-Git-Tag: release/2.6.0~691 X-Git-Url: https://git.donarmstrong.com/?a=commitdiff_plain;h=4464e54fb5ddc2b434698c8c01e94f3f6dc48193;p=debbugs.git [project @ 2005-07-24 15:06:54 by cjwatson] Move binary/source package handling from common.pl to a new Debbugs::Packages module. This will allow service to do some binary-to-source mapping for version tracking. --- diff --git a/Debbugs/Packages.pm b/Debbugs/Packages.pm new file mode 100644 index 00000000..e040bc95 --- /dev/null +++ b/Debbugs/Packages.pm @@ -0,0 +1,198 @@ +package Debbugs::Packages; + +use strict; + +# TODO: move config handling to a separate module +my $config_path = '/etc/debbugs'; +require "$config_path/config"; + +use Exporter (); +use vars qw($VERSION @ISA @EXPORT); + +BEGIN { + $VERSION = 1.00; + + @ISA = qw(Exporter); + @EXPORT = qw(getpkgsrc getpkgcomponent getsrcpkgs + binarytosource sourcetobinary); +} + +use Fcntl qw(O_RDONLY); +use MLDBM qw(DB_File); + +$MLDBM::RemoveTaint = 1; + +=head1 NAME + +Debbugs::Packages - debbugs binary/source package handling + +=head1 DESCRIPTION + +The Debbugs::Packages module provides support functions to map binary +packages to their corresponding source packages and vice versa. (This makes +sense for software distributions, where developers may work on a single +source package which produces several binary packages for use by users; it +may not make sense in other contexts.) + +=head1 METHODS + +=over 8 + +=item getpkgsrc + +Returns a reference to a hash of binary package names to their corresponding +source package names. + +=cut + +my $_pkgsrc; +my $_pkgcomponent; +sub getpkgsrc { + return $_pkgsrc if $_pkgsrc; + return {} unless defined $Debbugs::Packages::gPackageSource; + my %pkgsrc; + my %pkgcomponent; + + open(MM,"$Debbugs::Packages::gPackageSource") + or &quitcgi("open $Debbugs::Packages::gPackageSource: $!"); + while() { + next unless m/^(\S+)\s+(\S+)\s+(\S.*\S)\s*$/; + my ($bin,$cmp,$src)=($1,$2,$3); + $bin =~ y/A-Z/a-z/; + $pkgsrc{$bin}= $src; + $pkgcomponent{$bin}= $cmp; + } + close(MM); + $_pkgsrc = \%pkgsrc; + $_pkgcomponent = \%pkgcomponent; + return $_pkgsrc; +} + +=item 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", +"non-free"). + +=cut + +sub getpkgcomponent { + return $_pkgcomponent if $_pkgcomponent; + getpkgsrc(); + return $_pkgcomponent; +} + +=item getsrcpkgs + +Returns a list of the binary packages produced by a given source package. + +=cut + +sub getsrcpkgs { + my $src = shift; + return () if !$src; + my %pkgsrc = %{getpkgsrc()}; + my @pkgs; + foreach ( keys %pkgsrc ) { + push @pkgs, $_ if $pkgsrc{$_} eq $src; + } + return @pkgs; +} + +=item 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. + +=cut + +my %_binarytosource; +sub binarytosource { + my ($binname, $binver, $binarch) = @_; + + # TODO: This gets hit a lot, especially from buggyversion() - probably + # need an extra cache for speed here. + + if (tied %_binarytosource or + tie %_binarytosource, 'MLDBM', + $Debbugs::Packages::gBinarySourceMap, O_RDONLY) { + # avoid autovivification + if (exists $_binarytosource{$binname} and + exists $_binarytosource{$binname}{$binver}) { + if (defined $binarch) { + my $src = $_binarytosource{$binname}{$binver}{$binarch}; + return () unless defined $src; # not on this arch + # Copy the data to avoid tiedness problems. + return [@$src]; + } else { + # Get (srcname, srcver) pairs for all architectures and + # remove any duplicates. This involves some slightly tricky + # multidimensional hashing; sorry. Fortunately there'll + # usually only be one pair returned. + my %uniq; + for my $ar (keys %{$_binarytosource{$binname}{$binver}}) { + my $src = $_binarytosource{$binname}{$binver}{$ar}; + next unless defined $src; + $uniq{$src->[0]}{$src->[1]} = 1; + } + my @uniq; + for my $sn (sort keys %uniq) { + push @uniq, [$sn, $_] for sort keys %{$uniq{$sn}}; + } + return @uniq; + } + } + } + + # No $gBinarySourceMap, or it didn't have an entry for this name and + # version. Try $gPackageSource (unversioned) instead. + my $pkgsrc = getpkgsrc(); + if (exists $pkgsrc->{$binname}) { + return [$pkgsrc->{$binname}, $binver]; + } else { + return (); + } +} + +=item sourcetobinary + +Returns a list of references to triplets of binary package names, versions, +and architectures corresponding to a given source package name and version. +If the given source package name and version cannot be found in the database +but the source package name is in the unversioned package-to-source map +file, then a reference to a binary package name and version pair will be +returned, without the architecture. + +=cut + +my %_sourcetobinary; +sub sourcetobinary { + my ($srcname, $srcver) = @_; + + if (tied %_sourcetobinary or + tie %_sourcetobinary, 'MLDBM', + $Debbugs::Packages::gSourceBinaryMap, O_RDONLY) { + # avoid autovivification + if (exists $_sourcetobinary{$srcname} and + exists $_sourcetobinary{$srcname}{$srcver}) { + my $bin = $_sourcetobinary{$srcname}{$srcver}; + return () unless defined $bin; + # Copy the data to avoid tiedness problems. + return @$bin; + } + } + + # No $gSourceBinaryMap, or it didn't have an entry for this name and + # version. Try $gPackageSource (unversioned) instead. + my @srcpkgs = getsrcpkgs($srcname); + return map [$_, $srcver], @srcpkgs; +} + +=back + +=cut + +1; diff --git a/Makefile b/Makefile index 3eccbd7c..a5153226 100644 --- a/Makefile +++ b/Makefile @@ -14,7 +14,7 @@ examples_dir := $(doc_dir)/examples scripts_in := $(filter-out scripts/config.in scripts/errorlib.in scripts/text.in, $(wildcard scripts/*.in)) htmls_in := $(wildcard html/*.html.in) cgis := $(wildcard cgi/*.cgi cgi/*.pl) -perls := $(foreach name,Log MIME Versions,Debbugs/$(name).pm) +perls := $(foreach name,Log MIME Packages Versions,Debbugs/$(name).pm) install_exec := install -m755 -p install_data := install -m644 -p diff --git a/cgi/common.pl b/cgi/common.pl index ad9a902a..23802618 100644 --- a/cgi/common.pl +++ b/cgi/common.pl @@ -12,6 +12,7 @@ $config_path = '/etc/debbugs'; $lib_path = '/usr/lib/debbugs'; require "$lib_path/errorlib"; +use Debbugs::Packages; use Debbugs::Versions; use Debbugs::MIME qw(decode_rfc1522); @@ -732,34 +733,6 @@ sub getmaintainers { return $_maintainer; } -my $_pkgsrc; -my $_pkgcomponent; -sub getpkgsrc { - return $_pkgsrc if $_pkgsrc; - return {} unless defined $gPackageSource; - my %pkgsrc; - my %pkgcomponent; - - open(MM,"$gPackageSource") or &quitcgi("open $gPackageSource: $!"); - while() { - next unless m/^(\S+)\s+(\S+)\s+(\S.*\S)\s*$/; - ($a,$b,$c)=($1,$2,$3); - $a =~ y/A-Z/a-z/; - $pkgsrc{$a}= $c; - $pkgcomponent{$a}= $b; - } - close(MM); - $_pkgsrc = \%pkgsrc; - $_pkgcomponent = \%pkgcomponent; - return $_pkgsrc; -} - -sub getpkgcomponent { - return $_pkgcomponent if $_pkgcomponent; - getpkgsrc(); - return $_pkgcomponent; -} - my $_pseudodesc; sub getpseudodesc { return $_pseudodesc if $_pseudodesc; @@ -837,17 +810,6 @@ sub getbugstatus { return \%status; } -sub getsrcpkgs { - my $src = shift; - return () if !$src; - my %pkgsrc = %{getpkgsrc()}; - my @pkgs; - foreach ( keys %pkgsrc ) { - push @pkgs, $_ if $pkgsrc{$_} eq $src; - } - return @pkgs; -} - sub buglog { my $bugnum = shift; my $location = getbuglocation($bugnum, 'log'); @@ -950,77 +912,4 @@ sub getversiondesc { return undef; } -# Returns an array of zero or more references to (srcname, srcver) pairs. -# If $binarch is undef, returns results for all architectures. -my %_binarytosource; -sub binarytosource { - my ($binname, $binver, $binarch) = @_; - - # TODO: This gets hit a lot, especially from buggyversion() - probably - # need an extra cache for speed here. - - if (tied %_binarytosource or - tie %_binarytosource, 'MLDBM', $gBinarySourceMap, O_RDONLY) { - # avoid autovivification - if (exists $_binarytosource{$binname} and - exists $_binarytosource{$binname}{$binver}) { - if (defined $binarch) { - my $src = $_binarytosource{$binname}{$binver}{$binarch}; - return () unless defined $src; # not on this arch - # Copy the data to avoid tiedness problems. - return [@$src]; - } else { - # Get (srcname, srcver) pairs for all architectures and - # remove any duplicates. This involves some slightly tricky - # multidimensional hashing; sorry. Fortunately there'll - # usually only be one pair returned. - my %uniq; - for my $ar (keys %{$_binarytosource{$binname}{$binver}}) { - my $src = $_binarytosource{$binname}{$binver}{$ar}; - next unless defined $src; - $uniq{$src->[0]}{$src->[1]} = 1; - } - my @uniq; - for my $sn (sort keys %uniq) { - push @uniq, [$sn, $_] for sort keys %{$uniq{$sn}}; - } - return @uniq; - } - } - } - - # No $gBinarySourceMap, or it didn't have an entry for this name and - # version. Try $gPackageSource (unversioned) instead. - my $pkgsrc = getpkgsrc(); - if (exists $pkgsrc->{$binname}) { - return [$pkgsrc->{$binname}, $binver]; - } else { - return (); - } -} - -# Returns an array of zero or more references to -# (binname, binver[, binarch]) triplets. -my %_sourcetobinary; -sub sourcetobinary { - my ($srcname, $srcver) = @_; - - if (tied %_sourcetobinary or - tie %_sourcetobinary, 'MLDBM', $gSourceBinaryMap, O_RDONLY) { - # avoid autovivification - if (exists $_sourcetobinary{$srcname} and - exists $_sourcetobinary{$srcname}{$srcver}) { - my $bin = $_sourcetobinary{$srcname}{$srcver}; - return () unless defined $bin; - # Copy the data to avoid tiedness problems. - return @$bin; - } - } - - # No $gSourceBinaryMap, or it didn't have an entry for this name and - # version. Try $gPackageSource (unversioned) instead. - my @srcpkgs = getsrcpkgs($srcname); - return map [$_, $srcver], @srcpkgs; -} - 1;