BTS Search

From: Don Armstrong Date: Tue, 12 Sep 2006 08:14:52 +0000 (-0700) Subject: Add search and versioning support cgi scripts X-Git-Tag: release/2.6.0~585^2^2~87 X-Git-Url: https://git.donarmstrong.com/?a=commitdiff_plain;h=d06e5583e1ce75497cf3bb651a63cac0c17624f8;p=debbugs.git Add search and versioning support cgi scripts --- diff --git a/cgi/search.cgi b/cgi/search.cgi new file mode 100755 index 0000000..cf89c5b --- /dev/null +++ b/cgi/search.cgi @@ -0,0 +1,328 @@ +#!/usr/bin/perl + +use warnings; +use strict; + +# Hack to work on merkel where suexec is in place +BEGIN{ + if ($ENV{HTTP_HOST} eq 'merkel.debian.org') { + unshift @INC, qw(/home/don/perl/usr/share/perl5 /home/don/perl/usr/lib/perl5 /home/don/source); + $ENV{DEBBUGS_CONFIG_FILE}="/home/don/config_internal"; + } +} + + +use CGI::Simple; + +use CGI::Alert 'don@donarmstrong.com'; + +use Search::Estraier; +use Debbugs::Config qw(:config); +use Debbugs::Estraier; +use Debbugs::CGI qw(htmlize_packagelinks html_escape); +use HTML::Entities qw(encode_entities); + +my $q = new CGI::Simple; + +#my %var_defaults = (attr => 1,); + +my %cgi_var = cgi_parameters($q); + +$cgi_var{phrase} = '' if not defined $cgi_var{phrase}; +$cgi_var{max_results} = 10 if not defined $cgi_var{max_results}; +$cgi_var{attribute} = parse_attribute(\%cgi_var) || []; +$cgi_var{skip} = 0 if not defined $cgi_var{skip}; + +my @results; + +if (defined $cgi_var{next}) { + $cgi_var{search} = 1; + $cgi_var{skip} += $cgi_var{max_results}; +} +elsif (defined $cgi_var{prev}) { + $cgi_var{search} = 1; + $cgi_var{skip} -= $cgi_var{max_results}; + $cgi_var{skip} = 0 if $cgi_var{skip} < 0; +} + +my $nres; +if (defined $cgi_var{search} and length $cgi_var{phrase}) { + # connect to a node if we need to + my $node = new Search::Estraier::Node (url => $config{search_estraier}{url}, + user => $config{search_estraier}{user}, + passwd => $config{search_estraier}{pass}, + croak_on_error => 1, + ) or die "Unable to connect to the node"; + my $cond = new Search::Estraier::Condition; + $cond->set_phrase($cgi_var{phrase}); + if (defined $cgi_var{order_field} and length $cgi_var{order_field} and + defined $cgi_var{order_operator} and length $cgi_var{order_operator}) { + $cond->set_order($cgi_var{order_field}.' '.$cgi_var{order_operator}); + } + foreach my $attribute (@{$cgi_var{attribute}}) { + if (defined $$attribute{field} and defined $$attribute{value} and + defined $$attribute{operator} and length $$attribute{value}) { + $cond->add_attr(join(' ',map {$$attribute{$_}} qw(field operator value))); + } + } + $cond->set_skip($cgi_var{skip}) if defined $cgi_var{skip} and $cgi_var{skip} =~ /(\d+)/; + $cond->set_max($cgi_var{max_results}) if defined $cgi_var{max_results} and $cgi_var{max_results} =~ /^\d+$/; + print STDERR "skip: ".$cond->skip()."\n"; + print STDERR $node->cond_to_query($cond),qq(\n); + $nres = $node->search($cond,0) or + die "Unable to search for condition"; + +} +elsif (defined $cgi_var{add_attribute} and length $cgi_var{add_attribute}) { + push @{$cgi_var{attribute}}, {value => ''}; +} +elsif (grep /^delete_attribute_\d+$/, keys %cgi_var) { + foreach my $delete_key (sort {$b <=> $a} map {/^delete_attribute_(\d+)$/?($1):()} keys %cgi_var) { + splice @{$cgi_var{attribute}},$delete_key,1; + } +} + +my $url = 'http://bugs.debian.org/cgi-bin/bugreport.cgi?bug='; + +print <BTS Search + + + +

+ +

Phrase: + +

+END + +# phrase +# attributes +# NUMEQ : is equal to the number or date +# NUMNE : is not equal to the number or date +# NUMGT : is greater than the number or date +# NUMGE : is greater than or equal to the number or date +# NUMLT : is less than the number or date +# NUMLE : is less than or equal to the number or date +# NUMBT : is between the two numbers or dates +my @num_operators = (NUMEQ => 'equal to', + NUMNE => 'not equal to', + NUMGT => 'greater than', + NUMGE => 'greater than or equal to', + NUMLT => 'less than', + NUMLE => 'less than or equal to', + NUMBT => 'between', + ); + +# STREQ : is equal to the string +# STRNE : is not equal to the string +# STRINC : includes the string +# STRBW : begins with the string +# STREW : ends with the string +# STRAND : includes all tokens in the string +# STROR : includes at least one token in the string +# STROREQ : is equal to at least one token in the string +# STRRX : matches regular expressions of the string +my @str_operators = (STREQ => 'equal to', + STRNE => 'not equal to', + STRINC => 'includes', + STRBW => 'begins with', + STREW => 'ends with', + STRAND => 'includes all tokens', + STROR => 'includes at least one token', + STROREQ => 'is equal to at least one token', + STRRX => 'matches regular expression', + ); + +my @attributes_order = ('@cdate','@title','@author', + qw(status subject date submitter package tags severity), + ); +my %attributes = ('@cdate' => {name => 'Date', + type => 'num', + }, + '@title' => {name => 'Message subject', + type => 'str', + }, + '@author' => {name => 'Author', + type => 'str', + }, + status => {name => 'Status', + type => 'str', + }, + subject => {name => 'Bug Title', + type => 'num', + }, + date => {name => 'Submission date', + type => 'num', + }, + submitter => {name => 'Bug Submitter', + type => 'str', + }, + package => {name => 'Package', + type => 'str', + }, + tags => {name => 'Tags', + type => 'str', + }, + severity => {name => 'Severity', + type => 'str', + }, + ); +my $attr_num = 0; +print qq(

Attributes:

\n); +for my $attribute (@{$cgi_var{attribute}}) { + print qq(\n); + print qq(\n); + $$attribute{value}='' if not defined $$attribute{value}; + print qq(
\n); + $attr_num++; + +} +print qq(
); + +# order + +# STRA : ascending by string +# STRD : descending by string +# NUMA : ascending by number or date +# NUMD : descending by number or date + +my @order_operators = (STRA => 'ascending (string)', + STRD => 'descending (string)', + NUMA => 'ascending (number or date)', + NUMD => 'descending (number or date)', + ); + +print qq(

Order by: \n); +print qq(

\n); + +# max results + +print qq(

Max results:

\n); + +print qq(

\n); + + + +if (defined $nres) { + print "

Results

\n"; + my $hits = $nres->hits(); + print "

Hits: ".$hits; + if (($cgi_var{skip} > 0)) { + print q(); + } + if ($hits > ($cgi_var{skip}+$cgi_var{max_results})) { + print q(); + } + print "

\n"; + print qq(

$attr{severity}

#${bugnum}: $attr{'@title'} @{[htmlize_packagelinks($attr{package})]}
+$showseverity
+Sent by: @{[encode_entities($attr{'@author'})]} at $attr{'@cdate'}
+END + # Deal with the snippet + # make the things that match bits of the phrase bold, the rest normal. + my $snippet_mod = html_escape($attr{snippet}); + $snippet_mod =~ s/\n\n/ . . . /g; + for my $phrase_bits (split /\s+/,$cgi_var{phrase}) { + $snippet_mod =~ s{\n(\Q$phrase_bits\E)(?:\s+\Q$phrase_bits\E\n)}{''.$1.''}gei; + } + print "

$snippet_mod

\n"; + } + print "

"; + if (($cgi_var{skip} > 0)) { + print q(); + } + if ($hits > ($cgi_var{skip}+$cgi_var{max_results})) { + print q(); + } + print "

\n"; + +} + +print "

\n"; + +# This CGI should make an abstract method of displaying information +# about specific bugs and their messages; the information should be +# fairly similar to the way that pkgreport.cgi works, with the +# addition of snippit information and links to ajavapureapi/overview-summary.html specific message +# within the bug. + +# For now we'll brute force the display, but methods to display a bug +# or a particular bug message should be made common between the two +# setups + + +sub parse_attribute { + my ($cgi_var) = @_; + + my @attributes = (); + if (ref $$cgi_var{attribute_operator}) { + for my $elem (0 ... $#{$$cgi_var{attribute_operator}}) { + push @attributes,{map {($_,$$cgi_var{"attribute_$_"}[$elem]);} qw(value field operator)}; + } + } + elsif (defined $$cgi_var{attribute_operator}) { + push @attributes,{map {($_,$$cgi_var{"attribute_$_"});} qw(value field operator)}; + } + return \@attributes; +} + + +sub cgi_parameters { + my ($q) = @_; + + my %param; + foreach my $paramname ($q->param) { + my @value = $q->param($paramname); + $param{$paramname} = @value > 1 ? [@value] : $value[0]; + } + return %param; +} diff --git a/cgi/version.cgi b/cgi/version.cgi new file mode 100755 index 0000000..e0471a3 --- /dev/null +++ b/cgi/version.cgi @@ -0,0 +1,138 @@ +#!/usr/bin/perl + +use warnings; +use strict; + +# Hack to work on merkel where suexec is in place +BEGIN{ + if ($ENV{HTTP_HOST} eq 'merkel.debian.org') { + unshift @INC, qw(/home/don/perl/usr/share/perl5 /home/don/perl/usr/lib/perl5 /home/don/source); + $ENV{DEBBUGS_CONFIG_FILE}="/home/don/config_internal"; + } +} + + +use CGI::Simple; + +use CGI::Alert 'don@donarmstrong.com'; + +use Debbugs::Config qw(:config); +use Debbugs::CGI qw(htmlize_packagelinks html_escape); +use Debbugs::Versions; +use Debbugs::Versions::Dpkg; +use Debbugs::Packages qw(getversions); +use HTML::Entities qw(encode_entities); +use File::Temp qw(tempdir); +use IO::File; +use IO::Handle; + + + +my $q = new CGI::Simple; + +my %cgi_var = cgi_parameters($q); + +$cgi_var{package} = ['xterm'] if not defined $cgi_var{package}; +$cgi_var{found} = [] if not defined $cgi_var{found}; +$cgi_var{fixed} = [] if not defined $cgi_var{fixed}; + +# we only care about one package +$cgi_var{package} = $cgi_var{package}[0]; + +# we want to first load the appropriate file, +# then figure out which versions are there in which architectures, +my %versions; +my %version_to_dist; +for my $dist (qw(oldstable stable testing unstable)) { + $versions{$dist} = [getversions($cgi_var{package},$dist)]; + # make version_to_dist + foreach my $version (@{$versions{$dist}}){ + push @{$version_to_dist{$version}}, $dist; + } +} +# then figure out which are affected. + +my $srchash = substr $cgi_var{package}, 0, 1; +my $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp); +my $version_fh = new IO::File "$config{version_packages_dir}/$srchash/$cgi_var{package}", 'r'; +$version->load($version_fh); +# Here, we need to generate a short version to full version map +my %version_map; +foreach my $key (keys %{$version->{parent}}) { + my ($short_version) = $key =~ m{/(.+)$}; + next unless length $short_version; + # we let the first short version have presidence. + $version_map{$short_version} = $key if not exists $version_map{$short_version}; +} +# Turn all short versions into long versions +for my $found_fixed (qw(found fixed)) { + $cgi_var{$found_fixed} = + [ + map { + if ($_ !~ m{/}) { # short version + ($version_map{$_}); + } + else { # long version + ($_); + } + } @{$cgi_var{$found_fixed}} + ]; +} +my %all_states = $version->allstates($cgi_var{found},$cgi_var{fixed}); + +my $dot = "digraph G {\n"; +my %state = (found => ['fillcolor="salmon"', + 'style="filled"', + 'shape="diamond"', + ], + absent => ['fillcolor="grey"', + 'style="filled"', + ], + fixed => ['fillcolor="chartreuse"', + 'style="filled"', + 'shape="rect"', + ], + ); +foreach my $key (keys %all_states) { + my ($short_version) = $key =~ m{/(.+)$}; + my @attributes = @{$state{$all_states{$key}}}; + if (length $short_version and exists $version_to_dist{$short_version}) { + push @attributes, 'label="'.$key.'\n'."(".join(', ',@{$version_to_dist{$short_version}}).")\""; + } + my $node_attributes = qq("$key" [).join(',',@attributes).qq(]\n); + $dot .= $node_attributes; +} +foreach my $key (keys %{$version->{parent}}) { + $dot .= qq("$key").'->'.qq("$version->{parent}{$key}" [dir="back"])."\n" if defined $version->{parent}{$key}; +} +$dot .= "}\n"; + +my $temp_dir = tempdir(CLEANUP => 1); + +if (not defined $cgi_var{dot}) { + my $dot_fh = new IO::File "$temp_dir/temp.dot",'w' or + die "Unable to open $temp_dir/temp.dot for writing: $!"; + print {$dot_fh} $dot or die "Unable to print output to the dot file: $!"; + close $dot_fh or die "Unable to close the dot file: $!"; + system('dot','-Tpng',"$temp_dir/temp.dot",'-o',"$temp_dir/temp.png") == 0 + or print "Content-Type: text\n\nDot failed." and die "Dot failed: $?"; + my $png_fh = new IO::File "$temp_dir/temp.png", 'r' or + die "Unable to open $temp_dir/temp.png for reading: $!"; + print "Content-Type: image/png\n\n"; + print <$png_fh>; + close $png_fh; +} +else { + print "Content-Type: text\n\n"; + print $dot; +} + +sub cgi_parameters { + my ($q) = @_; + + my %param; + foreach my $paramname ($q->param) { + $param{$paramname} = [$q->param($paramname)] + } + return %param; +}