X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=cgi%2Fcommon.pl;h=05b8941ac7f84f8a2d2e07b9556ba9c6cabf577c;hb=62cac6b6d596b6f29286adf2e6781405f9fd04e9;hp=94e1eb35ee588a580a5f4d5269a19b7bfc835e63;hpb=c2c74685ea5da53572771b094cfbffd807833dfc;p=debbugs.git diff --git a/cgi/common.pl b/cgi/common.pl index 94e1eb3..05b8941 100644 --- a/cgi/common.pl +++ b/cgi/common.pl @@ -3,19 +3,23 @@ use DB_File; use Fcntl qw/O_RDONLY/; use Mail::Address; -use MLDBM qw/DB_File/; +use MLDBM qw(DB_File Storable); use POSIX qw/ceil/; use URI::Escape; +use Debbugs::Config qw(:globals :text); $config_path = '/etc/debbugs'; $lib_path = '/usr/lib/debbugs'; -require "$lib_path/errorlib"; +#require "$lib_path/errorlib"; -use Debbugs::Packages; +use Debbugs::Packages qw(:versions :mapping); use Debbugs::Versions; use Debbugs::MIME qw(decode_rfc1522); -use Debbugs::Common qw(:read :util); +use Debbugs::Common qw(:util); +use Debbugs::Status qw(:status :read :versions); +use Debbugs::CGI qw(:all); +use Debbugs::Bugs qw(count_bugs); $MLDBM::RemoveTaint = 1; @@ -84,7 +88,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', @@ -99,7 +103,7 @@ my %common_headers = ( "forwarded" => "forwarded to upstream software authors", "absent" => "not applicable to this version", }, - 'severity' => \%debbugs::gSeverityDisplay, + 'severity' => \%gSeverityDisplay, ); my $common_version; @@ -145,8 +149,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; @@ -233,60 +237,11 @@ $debug = 1 if (defined $ret{"debug"} && $ret{"debug"} eq "aj"); return %ret; } -sub quitcgi { - my $msg = shift; - print "Content-Type: text/html\n\n"; - print "Error\n"; - print "An error occurred. Dammit.\n"; - print "Error was: $msg.\n"; - print "\n"; - exit 0; -} - -#sub abort { -# my $msg = shift; -# my $Archive = $common_archive ? "archive" : ""; -# print header . start_html("Sorry"); -# print "Sorry bug #$msg doesn't seem to be in the $Archive database.\n"; -# print end_html; -# exit 0; -#} - -# Split a package string from the status file into a list of package names. -sub splitpackages { - my $pkgs = shift; - return unless defined $pkgs; - return map lc, split /[ \t?,()]+/, $pkgs; -} - -my %_parsedaddrs; -sub getparsedaddrs { - my $addr = shift; - return () unless defined $addr; - return @{$_parsedaddrs{$addr}} if exists $_parsedaddrs{$addr}; - @{$_parsedaddrs{$addr}} = Mail::Address->parse($addr); - return @{$_parsedaddrs{$addr}}; -} - # Generate a comma-separated list of HTML links to each package given in # $pkgs. $pkgs may be empty, in which case an empty string is returned, or # it may be a comma-separated list of package names. sub htmlpackagelinks { - my $pkgs = shift; - return unless defined $pkgs and $pkgs ne ''; - my $strong = shift; - my @pkglist = splitpackages($pkgs); - - my $openstrong = $strong ? '' : ''; - my $closestrong = $strong ? '' : ''; - - return 'Package' . (@pkglist > 1 ? 's' : '') . ': ' . - join(', ', - map { - '' . - $openstrong . htmlsanit($_) . $closestrong . '' - } @pkglist - ); + return htmlize_packagelinks(@_); } # Generate a comma-separated list of HTML links to each address given in @@ -294,20 +249,7 @@ sub htmlpackagelinks { # $urlfunc should be a reference to a function like mainturl or submitterurl # which returns the URL for each individual address. sub htmladdresslinks { - my ($prefixfunc, $urlfunc, $addresses) = @_; - if (defined $addresses and $addresses ne '') { - my @addrs = getparsedaddrs($addresses); - my $prefix = (ref $prefixfunc) ? $prefixfunc->(scalar @addrs) - : $prefixfunc; - return $prefix . - join ', ', map { sprintf '%s', - $urlfunc->($_->address), - htmlsanit($_->format) || '(unknown)' - } @addrs; - } else { - my $prefix = (ref $prefixfunc) ? $prefixfunc->(1) : $prefixfunc; - return sprintf '%s(unknown)', $prefix, $urlfunc->(''); - } + htmlize_addresslinks(@_); } # Generate a comma-separated list of HTML links to each maintainer given in @@ -367,7 +309,6 @@ sub htmlindexentrystatus { . htmlsanit(join(", ", sort(split(/\s+/, $status{tags})))) . "" if (length($status{tags})); - my @merged= split(/ /,$status{mergedwith}); my $mseparator= ";\nmerged with "; for my $m (@merged) { @@ -377,7 +318,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 { @@ -430,11 +371,9 @@ sub urlargs { return $args; } -sub submitterurl { pkg_etc_url(emailfromrfc822($_[0] || ""), "submitter"); } -sub mainturl { pkg_etc_url(emailfromrfc822($_[0] || ""), "maint"); } -sub pkgurl { pkg_etc_url($_[0] || "", "pkg"); } -sub srcurl { pkg_etc_url($_[0] || "", "src"); } -sub tagurl { pkg_etc_url($_[0] || "", "tag"); } +sub pkgurl { pkg_url(pkg => $_[0] || ""); } +sub srcurl { pkg_url(src => $_[0] || ""); } +sub tagurl { pkg_url(tag => $_[0] || ""); } sub pkg_etc_url { my $ref = shift; @@ -468,15 +407,6 @@ sub htmlsanit { return $in; } -sub maybelink { - my $in = shift; - if ($in =~ /^[a-zA-Z0-9+.-]+:/) { # RFC 1738 scheme - return qq{} . htmlsanit($in) . ''; - } else { - return htmlsanit($in); - } -} - sub bugurl { my $ref = shift; my $params = "bug=$ref"; @@ -524,7 +454,7 @@ sub allbugs { return @{getbugs(sub { 1 })}; } -sub bugmatches(\%\%) { +sub bugmatches { my ($hash, $status) = @_; foreach my $key( keys( %$hash ) ) { my $value = $hash->{$key}; @@ -533,14 +463,14 @@ sub bugmatches(\%\%) { } return 0; } -sub bugfilter($%) { - my ($bug, %status) = @_; - our (%seenmerged); - if (%common_include) { - return 1 if (!bugmatches(%common_include, %status)); +sub bugfilter { + my ($bug, $status,$seen_merged,$common_include,$common_exclude,$repeat_merged,) = @_; + #our (%seenmerged); + if ($common_include) { + return 1 if (!bugmatches($common_include, $status)); } - if (%common_exclude) { - return 1 if (bugmatches(%common_exclude, %status)); + if ($common_exclude) { + return 1 if (bugmatches($common_exclude, $status)); } my @merged = sort {$a<=>$b} $bug, split(/ /, $status{mergedwith}); my $daysold = int((time - $status{date}) / 86400); # seconds to days @@ -651,33 +581,15 @@ 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; } sub countbugs { - my $bugfunc = shift; - if ($common_archive) { - open I, "<$debbugs::gSpoolDir/index.archive" - or &quitcgi("$debbugs::gSpoolDir/index.archive: $!"); - } else { - open I, "<$debbugs::gSpoolDir/index.db" - or &quitcgi("$debbugs::gSpoolDir/index.db: $!"); - } - - my %count = (); - while() - { - if (m/^(\S+)\s+(\d+)\s+(\d+)\s+(\S+)\s+\[\s*([^]]*)\s*\]\s+(\w+)\s+(.*)$/) { - my @x = $bugfunc->(pkg => $1, bug => $2, status => $4, - submitter => $5, severity => $6, tags => $7); - local $_; - $count{$_}++ foreach @x; - } - } - close I; - return %count; + return count_bugs(function=>shift, + archive => $commonarchive, + ); } sub getbugs { @@ -690,39 +602,31 @@ 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) { my %lookup; print STDERR "optimized\n" if ($debug); - tie %lookup, DB_File => $fastidx, O_RDONLY + tie %lookup, MLDBM => $fastidx, O_RDONLY or die "$0: can't open $fastidx ($!)\n"; while ($key = shift) { my $bugs = $lookup{$key}; if (defined $bugs) { - push @result, (unpack 'N*', $bugs); - } elsif (defined $lookup{"count $key"}) { - my $which = 0; - while (1) { - $bugs = $lookup{"$which $key"}; - last unless defined $bugs; - push @result, (unpack 'N*', $bugs); - $which += 100; - } - } + push @result, keys %{$bugs}; + } } untie %lookup; 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+(.*)$/) { @@ -764,229 +668,16 @@ sub maintencoded { return $encoded; } -my $_maintainer; -sub getmaintainers { - return $_maintainer if $_maintainer; - my %maintainer; - - open(MM,"$debbugs::gMaintainerFile") or &quitcgi("open $debbugs::gMaintainerFile: $!"); - while() { - next unless m/^(\S+)\s+(\S.*\S)\s*$/; - ($a,$b)=($1,$2); - $a =~ y/A-Z/a-z/; - $maintainer{$a}= $b; - } - close(MM); - if (defined $debbugs::gMaintainerFileOverride) { - open(MM,"$debbugs::gMaintainerFileOverride") or &quitcgi("open $debbugs::gMaintainerFileOverride: $!"); - while() { - next unless m/^(\S+)\s+(\S.*\S)\s*$/; - ($a,$b)=($1,$2); - $a =~ y/A-Z/a-z/; - $maintainer{$a}= $b; - } - close(MM); - } - $_maintainer = \%maintainer; - return $_maintainer; -} - -my $_pseudodesc; -sub getpseudodesc { - return $_pseudodesc if $_pseudodesc; - my %pseudodesc; - - open(PSEUDO, "< $debbugs::gPseudoDescFile") or &quitcgi("open $debbugs::gPseudoDescFile: $!"); - while() { - next unless m/^(\S+)\s+(\S.*\S)\s*$/; - $pseudodesc{lc $1} = $2; - } - close(PSEUDO); - $_pseudodesc = \%pseudodesc; - return $_pseudodesc; -} sub getbugstatus { - my $bugnum = shift; - - my %status; - - if ( $use_bug_idx eq 1 && exists( $bugidx{ $bugnum } ) ) { - %status = %{ $bugidx{ $bugnum } }; - $status{ pending } = $status{ status }; - $status{ id } = $bugnum; - return \%status; - } - - my $location = getbuglocation( $bugnum, 'summary' ); - return {} if ( !$location ); - %status = %{ readbug( $bugnum, $location ) }; - $status{ id } = $bugnum; - - - if (defined $common_bugusertags{$bugnum}) { - $status{keywords} = "" unless defined $status{keywords}; - $status{keywords} .= " " unless $status{keywords} eq ""; - $status{keywords} .= join(" ", @{$common_bugusertags{$bugnum}}); - } - $status{tags} = $status{keywords}; - my %tags = map { $_ => 1 } split ' ', $status{tags}; - - $status{"package"} =~ s/\s*$//; - $status{"package"} = 'unknown' if ($status{"package"} eq ''); - $status{"severity"} = 'normal' if ($status{"severity"} eq ''); - - $status{"pending"} = 'pending'; - $status{"pending"} = 'forwarded' if (length($status{"forwarded"})); - $status{"pending"} = 'pending-fixed' if ($tags{pending}); - $status{"pending"} = 'fixed' if ($tags{fixed}); - - my @versions; - if (defined $common_version) { - @versions = ($common_version); - } elsif (defined $common_dist) { - @versions = getversions($status{package}, $common_dist, $common_arch); - } - - # TODO: This should probably be handled further out for efficiency and - # for more ease of distinguishing between pkg= and src= queries. - my @sourceversions = makesourceversions($status{package}, $common_arch, - @versions); - - if (@sourceversions) { - # Resolve bugginess states (we might be looking at multiple - # architectures, say). Found wins, then fixed, then absent. - my $maxbuggy = 'absent'; - for my $version (@sourceversions) { - my $buggy = buggyversion($bugnum, $version, \%status); - if ($buggy eq 'found') { - $maxbuggy = 'found'; - last; - } elsif ($buggy eq 'fixed' and $maxbuggy ne 'found') { - $maxbuggy = 'fixed'; - } - } - if ($maxbuggy eq 'absent') { - $status{"pending"} = 'absent'; - } elsif ($maxbuggy eq 'fixed') { - $status{"pending"} = 'done'; - } - } - - if (length($status{done}) and - (not @sourceversions or not @{$status{fixed_versions}})) { - $status{"pending"} = 'done'; - } - - return \%status; -} - -sub buglog { - my $bugnum = shift; - my $location = getbuglocation($bugnum, 'log'); - return getbugcomponent($bugnum, 'log', $location) if ($location); - $location = getbuglocation($bugnum, 'log.gz'); - 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. -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 @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; - } - } - - return sort keys %sourceversions; -} - -my %_versionobj; -sub buggyversion { - my ($bug, $ver, $status) = @_; - return '' unless defined $debbugs::gVersionPackagesDir; - my $src = getpkgsrc()->{$status->{package}}; - $src = $status->{package} unless defined $src; - - my $tree; - if (exists $_versionobj{$src}) { - $tree = $_versionobj{$src}; - } else { - $tree = Debbugs::Versions->new(\&DpkgVer::vercmp); - my $srchash = substr $src, 0, 1; - if (open VERFILE, "< $debbugs::gVersionPackagesDir/$srchash/$src") { - $tree->load(\*VERFILE); - close VERFILE; - } - $_versionobj{$src} = $tree; - } - - my @found = makesourceversions($status->{package}, undef, - @{$status->{found_versions}}); - my @fixed = makesourceversions($status->{package}, undef, - @{$status->{fixed_versions}}); - - return $tree->buggy($ver, \@found, \@fixed); -} - -my %_versions; -sub getversions { - my ($pkg, $dist, $arch) = @_; - return () unless defined $debbugs::gVersionIndex; - $dist = 'unstable' unless defined $dist; - - unless (tied %_versions) { - tie %_versions, 'MLDBM', $debbugs::gVersionIndex, O_RDONLY - or die "can't open versions index: $!"; - } - - if (defined $arch and exists $_versions{$pkg}{$dist}{$arch}) { - my $ver = $_versions{$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'; - } - if (%uniq) { - return keys %uniq; - } elsif (exists $_versions{$pkg}{$dist}{source}) { - # Maybe this is actually a source package with no corresponding - # binaries? - return $_versions{$pkg}{$dist}{source}; - } else { - return (); - } - } + my ($bug) = @_; + return get_bug_status(bug => $bug, + $use_bug_idx?(bug_index => \%bugidx):(), + usertags => \%common_bugusertags, + (defined $common_dist)?(dist => $common_dist):(), + (defined $common_version)?(version => $common_version):(), + (defined $common_arch)?(arch => $common_arch):(), + ); } sub getversiondesc {