From: Don Armstrong Date: Sat, 11 Nov 2006 07:30:56 +0000 (-0800) Subject: * Move makesourceversions to Debbugs::Packages X-Git-Tag: release/2.6.0~585^2^2~77 X-Git-Url: https://git.donarmstrong.com/?a=commitdiff_plain;h=3e8c3591fe26e59a2b7dab968f7246756f738005;p=debbugs.git * Move makesourceversions to Debbugs::Packages * Only lookup the in the tied hash once; store the result, and avoid looking up it again. [This avoids wasting time thaw'ing it multiple times, and the lookup time.] * use Debbugs::Config qw(:globals) in common.pl; get rid of useless debbugs:: cruft. --- diff --git a/Debbugs/Packages.pm b/Debbugs/Packages.pm index 00eda54..1274193 100644 --- a/Debbugs/Packages.pm +++ b/Debbugs/Packages.pm @@ -14,7 +14,7 @@ BEGIN { @EXPORT = (); %EXPORT_TAGS = (versions => [qw(getversions)], mapping => [qw(getpkgsrc getpkgcomponent getsrcpkgs), - qw(binarytosource sourcetobinary) + qw(binarytosource sourcetobinary makesourceversions) ], ); @EXPORT_OK = (); @@ -24,7 +24,9 @@ BEGIN { use Fcntl qw(O_RDONLY); use MLDBM qw(DB_File Storable); +use Storable qw(dclone); +$MLDBM::DumpMeth = 'portable'; $MLDBM::RemoveTaint = 1; =head1 NAME @@ -52,11 +54,13 @@ source package names. my $_pkgsrc; my $_pkgcomponent; +my $_srcpkg; sub getpkgsrc { return $_pkgsrc if $_pkgsrc; return {} unless defined $Debbugs::Packages::gPackageSource; my %pkgsrc; my %pkgcomponent; + my %srcpkg; open(MM,"$Debbugs::Packages::gPackageSource") or die("open $Debbugs::Packages::gPackageSource: $!"); @@ -65,11 +69,13 @@ sub getpkgsrc { my ($bin,$cmp,$src)=($1,$2,$3); $bin =~ y/A-Z/a-z/; $pkgsrc{$bin}= $src; + push @{$srcpkg{$src}}, $bin; $pkgcomponent{$bin}= $cmp; } close(MM); $_pkgsrc = \%pkgsrc; $_pkgcomponent = \%pkgcomponent; + $_srcpkg = \%srcpkg; return $_pkgsrc; } @@ -95,13 +101,9 @@ Returns a list of the binary packages produced by a given source package. sub getsrcpkgs { my $src = shift; - return () if !$src; - my %pkgsrc = %{getpkgsrc()}; - my @pkgs; - foreach ( keys %pkgsrc ) { - push @pkgs, $_ if $pkgsrc{$_} eq $src; - } - return @pkgs; + getpkgsrc() if not defined $_srcpkg; + return () if not defined $src or not exists $_srcpkg->{$src}; + return @{$_srcpkg->{$src}}; } =item binarytosource @@ -125,21 +127,23 @@ sub binarytosource { tie %_binarytosource, 'MLDBM', $Debbugs::Packages::gBinarySourceMap, O_RDONLY) { # avoid autovivification - if (exists $_binarytosource{$binname} and - exists $_binarytosource{$binname}{$binver}) { + my $binary = $_binarytosource{$binname}; + return () unless defined $binary; + my %binary = %{$binary}; + if (exists $binary{$binver}) { if (defined $binarch) { - my $src = $_binarytosource{$binname}{$binver}{$binarch}; + my $src = $binary{$binver}{$binarch}; return () unless defined $src; # not on this arch # Copy the data to avoid tiedness problems. - return [@$src]; + return dclone($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}; + for my $ar (keys %{$binary{$binver}}) { + my $src = $binary{$binver}{$ar}; next unless defined $src; $uniq{$src->[0]}{$src->[1]} = 1; } @@ -176,11 +180,12 @@ sub sourcetobinary { tie %_sourcetobinary, 'MLDBM', $Debbugs::Packages::gSourceBinaryMap, O_RDONLY) { # avoid autovivification - if (exists $_sourcetobinary{$srcname} and - exists $_sourcetobinary{$srcname}{$srcver}) { - my $bin = $_sourcetobinary{$srcname}{$srcver}; + my $source = $_sourcetobinary{$srcname}; + return () unless defined $source; + my %source = %{$source}; + if (exists $source{$srcver}) { + my $bin = $source{$srcver}; return () unless defined $bin; - # Copy the data to avoid tiedness problems. return @$bin; } } @@ -193,7 +198,8 @@ sub sourcetobinary { =item getversions -Returns versions of the package in distribution at a specific architecture +Returns versions of the package in a distribution at a specific +architecture =cut @@ -207,22 +213,25 @@ sub getversions { tie %_versions, 'MLDBM', $gVersionIndex, O_RDONLY or die "can't open versions index: $!"; } + my $version = $_versions{$pkg}; + return () unless defined $version; + my %version = %{$version}; - if (defined $arch and exists $_versions{$pkg}{$dist}{$arch}) { - my $ver = $_versions{$pkg}{$dist}{$arch}; + if (defined $arch and exists $version{$dist}{$arch}) { + my $ver = $version{$pkg}{$dist}{$arch}; return $ver if defined $ver; return (); } else { my %uniq; - for my $ar (keys %{$_versions{$pkg}{$dist}}) { - $uniq{$_versions{$pkg}{$dist}{$ar}} = 1 unless $ar eq 'source'; + for my $ar (keys %{$version{$dist}}) { + $uniq{$version{$dist}{$ar}} = 1 unless $ar eq 'source'; } if (%uniq) { return keys %uniq; - } elsif (exists $_versions{$pkg}{$dist}{source}) { + } elsif (exists $version{$dist}{source}) { # Maybe this is actually a source package with no corresponding # binaries? - return $_versions{$pkg}{$dist}{source}; + return $version{$dist}{source}; } else { return (); } @@ -230,6 +239,65 @@ sub getversions { } +=item makesourceversions + + @{$cgi_var{found}} = makesourceversions($cgi_var{package},undef,@{$cgi_var{found}}); + +Canonicalize versions into source versions, which have an explicitly +named source package. This is used to cope with source packages whose +names have changed during their history, and with cases where source +version numbers differ from binary version numbers. + +=cut + +my %_sourceversioncache = (); +sub makesourceversions { + my $pkg = shift; + my $arch = shift; + my %sourceversions; + + for my $version (@_) { + if ($version =~ m[/]) { + # 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; + } + 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 diff --git a/cgi/common.pl b/cgi/common.pl index a98a570..b3656c8 100644 --- a/cgi/common.pl +++ b/cgi/common.pl @@ -18,7 +18,7 @@ use Debbugs::MIME qw(decode_rfc1522); use Debbugs::Common qw(:util); use Debbugs::Status qw(:read :versions); use Debbugs::CGI qw(:all); - +use Debbugs::Config qw(:globals); $MLDBM::RemoveTaint = 1; @@ -87,7 +87,7 @@ my %field_match = ( my @common_grouping = ( 'severity', 'pending' ); my %common_grouping_order = ( 'pending' => [ qw( pending forwarded pending-fixed fixed done absent ) ], - 'severity' => \@debbugs::gSeverityList, + 'severity' => \@gSeverityList, ); my %common_grouping_display = ( 'pending' => 'Status', @@ -102,7 +102,7 @@ my %common_headers = ( "forwarded" => "forwarded to upstream software authors", "absent" => "not applicable to this version", }, - 'severity' => \%debbugs::gSeverityDisplay, + 'severity' => \%gSeverityDisplay, ); my $common_version; @@ -148,8 +148,8 @@ sub set_option { $use_bug_idx = $val; if ( $val ) { $common_headers{pending}{open} = $common_headers{pending}{pending}; - my $bugidx = tie %bugidx, MLDBM => "$debbugs::gSpoolDir/realtime/bug.idx", O_RDONLY - or quitcgi( "$0: can't open $debbugs::gSpoolDir/realtime/bug.idx ($!)\n" ); + my $bugidx = tie %bugidx, MLDBM => "$gSpoolDir/realtime/bug.idx", O_RDONLY + or quitcgi( "$0: can't open $gSpoolDir/realtime/bug.idx ($!)\n" ); $bugidx->RemoveTaint(1); } else { untie %bugidx; @@ -343,7 +343,7 @@ sub htmlindexentrystatus { if (length($status{done})) { $result .= ";\nDone: " . htmlsanit($status{done}); - $days = ceil($debbugs::gRemoveAge - -M buglog($status{id})); + $days = ceil($gRemoveAge - -M buglog($status{id})); if ($days >= 0) { $result .= ";\nWill be archived:" . ( $days == 0 ? " today" : $days == 1 ? " in $days day" : " in $days days" ); } else { @@ -608,7 +608,7 @@ sub htmlizebugs { } $result = $header . $result if ( $common{show_list_header} ); - $result .= $debbugs::gHTMLExpireNote if $debbugs::gRemoveAge and $anydone; + $result .= $gHTMLExpireNote if $gRemoveAge and $anydone; $result .= "
" . $footer if ( $common{show_list_footer} ); return $result; } @@ -616,11 +616,11 @@ sub htmlizebugs { sub countbugs { my $bugfunc = shift; if ($common_archive) { - open I, "<$debbugs::gSpoolDir/index.archive" - or &quitcgi("$debbugs::gSpoolDir/index.archive: $!"); + open I, "<$gSpoolDir/index.archive" + or &quitcgi("$gSpoolDir/index.archive: $!"); } else { - open I, "<$debbugs::gSpoolDir/index.db" - or &quitcgi("$debbugs::gSpoolDir/index.db: $!"); + open I, "<$gSpoolDir/index.db" + or &quitcgi("$gSpoolDir/index.db: $!"); } my %count = (); @@ -647,9 +647,9 @@ sub getbugs { if (!defined $opt) { # leave $fastidx undefined; } elsif (!$common_archive) { - $fastidx = "$debbugs::gSpoolDir/by-$opt.idx"; + $fastidx = "$gSpoolDir/by-$opt.idx"; } else { - $fastidx = "$debbugs::gSpoolDir/by-$opt-arc.idx"; + $fastidx = "$gSpoolDir/by-$opt-arc.idx"; } if (defined $fastidx && -e $fastidx) { @@ -667,11 +667,11 @@ print STDERR "optimized\n" if ($debug); print STDERR "done optimized\n" if ($debug); } else { if ( $common_archive ) { - open I, "<$debbugs::gSpoolDir/index.archive" - or &quitcgi("$debbugs::gSpoolDir/index.archive: $!"); + open I, "<$gSpoolDir/index.archive" + or &quitcgi("$gSpoolDir/index.archive: $!"); } else { - open I, "<$debbugs::gSpoolDir/index.db" - or &quitcgi("$debbugs::gSpoolDir/index.db: $!"); + open I, "<$gSpoolDir/index.db" + or &quitcgi("$gSpoolDir/index.db: $!"); } while() { if (m/^(\S+)\s+(\d+)\s+(\d+)\s+(\S+)\s+\[\s*([^]]*)\s*\]\s+(\w+)\s+(.*)$/) { @@ -718,7 +718,7 @@ sub getmaintainers { return $_maintainer if $_maintainer; my %maintainer; - open(MM,"$debbugs::gMaintainerFile") or &quitcgi("open $debbugs::gMaintainerFile: $!"); + open(MM,"$gMaintainerFile") or &quitcgi("open $gMaintainerFile: $!"); while() { next unless m/^(\S+)\s+(\S.*\S)\s*$/; ($a,$b)=($1,$2); @@ -726,8 +726,8 @@ sub getmaintainers { $maintainer{$a}= $b; } close(MM); - if (defined $debbugs::gMaintainerFileOverride) { - open(MM,"$debbugs::gMaintainerFileOverride") or &quitcgi("open $debbugs::gMaintainerFileOverride: $!"); + if (defined $gMaintainerFileOverride) { + open(MM,"$gMaintainerFileOverride") or &quitcgi("open $gMaintainerFileOverride: $!"); while() { next unless m/^(\S+)\s+(\S.*\S)\s*$/; ($a,$b)=($1,$2); @@ -745,7 +745,7 @@ sub getpseudodesc { return $_pseudodesc if $_pseudodesc; my %pseudodesc; - open(PSEUDO, "< $debbugs::gPseudoDescFile") or &quitcgi("open $debbugs::gPseudoDescFile: $!"); + open(PSEUDO, "< $gPseudoDescFile") or &quitcgi("open $gPseudoDescFile: $!"); while() { next unless m/^(\S+)\s+(\S.*\S)\s*$/; $pseudodesc{lc $1} = $2; @@ -838,61 +838,11 @@ sub buglog { return getbugcomponent($bugnum, 'log.gz', $location); } -# Canonicalize versions into source versions, which have an explicitly -# named source package. This is used to cope with source packages whose -# names have changed during their history, and with cases where source -# version numbers differ from binary version numbers. -my %_sourceversioncache = (); -sub makesourceversions { - my $pkg = shift; - my $arch = shift; - my %sourceversions; - - for my $version (@_) { - if ($version =~ m[/]) { - # 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; - } - 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; -} my %_versionobj; sub buggyversion { my ($bug, $ver, $status) = @_; - return '' unless defined $debbugs::gVersionPackagesDir; + return '' unless defined $gVersionPackagesDir; my $src = getpkgsrc()->{$status->{package}}; $src = $status->{package} unless defined $src; @@ -902,7 +852,7 @@ sub buggyversion { } else { $tree = Debbugs::Versions->new(\&DpkgVer::vercmp); my $srchash = substr $src, 0, 1; - if (open VERFILE, "< $debbugs::gVersionPackagesDir/$srchash/$src") { + if (open VERFILE, "< $gVersionPackagesDir/$srchash/$src") { $tree->load(\*VERFILE); close VERFILE; }