--- /dev/null
+Makefile.perl
+Makefile.perl.old
+build-stamp
+install-stamp
'&maybelink' => \&Debbugs::CGI::maybelink,
},
);
-
- my $result = "";
-
- my $showseverity;
- if ($status{severity} eq 'normal') {
- $showseverity = '';
- }
- elsif (isstrongseverity($status{severity})) {
- $showseverity = "Severity: <em class=\"severity\">$status{severity}</em>;\n";
- }
- else {
- $showseverity = "Severity: <em>$status{severity}</em>;\n";
- }
-
- $result .= package_links(package => $status{package},
- options => $param{options},
- );
-
- my $showversions = '';
- if (@{$status{found_versions}}) {
- my @found = @{$status{found_versions}};
- $showversions .= join ', ', map {s{/}{ }; html_escape($_)} @found;
- }
- if (@{$status{fixed_versions}}) {
- $showversions .= '; ' if length $showversions;
- $showversions .= '<strong>fixed</strong>: ';
- my @fixed = @{$status{fixed_versions}};
- $showversions .= join ', ', map {s{/}{ }; html_escape($_)} @fixed;
- }
- $result .= ' (<a href="'.
- version_url(package => $status{package},
- found => $status{found_versions},
- fixed => $status{fixed_versions},
- ).qq{">$showversions</a>)} if length $showversions;
- $result .= ";\n";
-
- $result .= $showseverity;
- $result .= "Reported by: ".package_links(submitter=>$status{originator},
- class => "submitter",
- );
- $result .= ";\nOwned by: " . package_links(owner => $status{owner},
- class => "submitter",
- )
- if length $status{owner};
- $result .= ";\nTags: <strong>"
- . html_escape(join(", ", sort(split(/\s+/, $status{tags}))))
- . "</strong>"
- if (length($status{tags}));
-
- $result .= (length($status{mergedwith})?";\nMerged with ":"") .
- bug_links(bug => [split(/ /,$status{mergedwith})],
- class => "submitter",
- );
- $result .= (length($status{blockedby})?";\nBlocked by ":"") .
- bug_links(bug => [split(/ /,$status{blockedby})],
- class => "submitter",
- );
- $result .= (length($status{blocks})?";\nBlocks ":"") .
- bug_links(bug => [split(/ /,$status{blocks})],
- class => "submitter",
- );
-
- if (length($status{done})) {
- $result .= "<br><strong>Done:</strong> " . html_escape($status{done});
- my $days = bug_archiveable(bug => $status{id},
- status => \%status,
- days_until => 1,
- );
- if ($days >= 0 and defined $status{location} and $status{location} ne 'archive') {
- $result .= ";\n<strong>Can be archived" . ( $days == 0 ? " today" : $days == 1 ? " in $days day" : " in $days days" ) . "</strong>";
- }
- elsif (defined $status{location} and $status{location} eq 'archived') {
- $result .= ";\n<strong>Archived.</strong>";
- }
- }
-
- unless (length($status{done})) {
- if (length($status{forwarded})) {
- $result .= ";\n<strong>Forwarded</strong> to "
- . join(', ',
- map {maybelink($_)}
- split /\,\s+/,$status{forwarded}
- );
- }
- # Check the age of the logfile
- my ($days_last,$eng_last) = secs_to_english(time - $status{log_modified});
- my ($days,$eng) = secs_to_english(time - $status{date});
-
- if ($days >= 7) {
- my $font = "";
- my $efont = "";
- $font = "em" if ($days > 30);
- $font = "strong" if ($days > 60);
- $efont = "</$font>" if ($font);
- $font = "<$font>" if ($font);
-
- $result .= ";\n ${font}$eng old$efont";
- }
- if ($days_last > 7) {
- my $font = "";
- my $efont = "";
- $font = "em" if ($days_last > 30);
- $font = "strong" if ($days_last > 60);
- $efont = "</$font>" if ($font);
- $font = "<$font>" if ($font);
-
- $result .= ";\n ${font}Modified $eng_last ago$efont";
- }
- }
-
- $result .= ".";
-
- return $result;
}
qw(getmaintainers_reverse),
qw(getpseudodesc),
],
- misc => [qw(make_list globify_scalar english_join)],
+ misc => [qw(make_list globify_scalar english_join checkpid)],
date => [qw(secs_to_english)],
quit => [qw(quit)],
lock => [qw(filelock unfilelock lockpid)],
sub lockpid {
my ($pidfile) = @_;
if (-e $pidfile) {
- my $pidfh = IO::File->new($pidfile, 'r') or
- die "Unable to open pidfile $pidfile: $!";
- local $/;
- my $pid = <$pidfh>;
- ($pid) = $pid =~ /(\d+)/;
- if (defined $pid and kill(0,$pid)) {
- return 0;
- }
- close $pidfh;
+ my $pid = checkpid($pidfile);
+ die "Unable to read pidfile $pidfile: $!" if not defined $pid;
+ return 0 if $pid != 0;
unlink $pidfile or
die "Unable to unlink stale pidfile $pidfile $!";
}
return 1;
}
+=head2 checkpid
+
+ checkpid('/path/to/pidfile');
+
+Checks a pid file and determines if the process listed in the pidfile
+is still running. Returns the pid if it is, 0 if it isn't running, and
+undef if the pidfile doesn't exist or cannot be read.
+
+=cut
+
+sub checkpid{
+ my ($pidfile) = @_;
+ if (-e $pidfile) {
+ my $pidfh = IO::File->new($pidfile, 'r') or
+ return undef;
+ local $/;
+ my $pid = <$pidfh>;
+ close $pidfh;
+ ($pid) = $pid =~ /(\d+)/;
+ if (defined $pid and kill(0,$pid)) {
+ return $pid;
+ }
+ return 0;
+ }
+ else {
+ return undef;
+ }
+}
+
=head1 QUIT
[qw(i386 amd64 arm powerpc sparc alpha)]
);
+=item affects_distribution_tags
+
+List of tags which restrict the buggy state to a set of distributions.
+
+The set of distributions that are buggy is the intersection of the set
+of distributions that would be buggy without reference to these tags
+and the set of these tags that are distributions which are set on a
+bug.
+
+Setting this to [] will remove this feature.
+
+Default: @{$config{distributions}}
+
+=cut
+
+set_default(\%config,'affects_distribution_tags',
+ [@{$config{distributions}}],
+ );
+
=item removal_unremovable_tags
Bugs which have these tags set cannot be archived
set_default(\%config,'severity_display',{critical => "Critical $config{bugs}",
grave => "Grave $config{bugs}",
+ serious => "Serious $config{bugs}",
+ important=> "Important $config{bugs}",
normal => "Normal $config{bugs}",
+ minor => "Minor $config{bugs}",
wishlist => "Wishlist $config{bugs}",
});
my $log = [];
my @records = Debbugs::Log::read_log_records(bug_num => $param{bug});
if ($param{summary} == 0) {
- $log = $param{log};
+ $log = $param{message};
$summary_msg = @records + 1;
}
else {
action => {type => SCALAR,
},
requester => {type => SCALAR,
+ default => '',
},
request_addr => {type => SCALAR,
+ default => '',
},
location => {type => SCALAR,
optional => 1,
},
message => {type => SCALAR|ARRAYREF,
+ default => '',
},
+ desc => {type => SCALAR,
+ default => '',
+ },
get_lock => {type => BOOLEAN,
default => 1,
},
}
my $log = IO::File->new(">>$log_location") or
die "Unable to open $log_location for appending: $!";
- print {$log} "\6\n".
+ my $msg = "\6\n".
"<!-- time:".time." -->\n".
- "<strong>".html_escape($param{action})."</strong>\n".
- "Request was from <code>".html_escape($param{requester})."</code>\n".
- "to <code>".html_escape($param{request_addr})."</code>. \n".
- "\3\n".
- "\7\n",escape_log(make_list($param{message})),"\n\3\n"
+ "<strong>".html_escape($param{action})."</strong>\n";
+ if (length $param{requester}) {
+ $msg .= "Request was from <code>".html_escape($param{requester})."</code>\n";
+ }
+ if (length $param{request_addr}) {
+ $msg .= "to <code>".html_escape($param{request_addr})."</code>";
+ }
+ if (length $param{desc}) {
+ $msg .= ":<br>\n$param{desc}\n";
+ }
+ else {
+ $msg .= ".\n";
+ }
+ $msg .= "\3\n";
+ if ((ref($param{message}) and @{$param{message}}) or length($param{message})) {
+ $msg .= "\7\n".join('',escape_log(make_list($param{message})))."\n\3\n"
or die "Unable to append to $log_location: $!";
+ }
+ print {$log} $msg or die "Unable to append to $log_location: $!";
close $log or die "Unable to close $log_location: $!";
if ($param{get_lock}) {
- unlockfile();
+ unfilelock();
}
$status = getbugcomponent($lref, 'summary', $location);
$log = getbugcomponent($lref, 'log' , $location);
return undef unless defined $status;
+ return undef if not -e $status;
}
else {
$status = $param{summary};
my ($bug_num,$location) = @_;
my $locks = 0;
my @data = (lockreadbug(@_));
- if (not @data and not defined $data[0]) {
+ if (not @data or not defined $data[0]) {
return ($locks,undef);
}
$locks++;
filelock("$config{spool_dir}/lock/merge");
$locks++;
@data = (lockreadbug(@_));
- if (not @data and not defined $data[0]) {
+ if (not @data or not defined $data[0]) {
unfilelock(); #for merge lock above
$locks--;
return ($locks,undef);
}
}
} elsif (defined $param{dist}) {
+ my %affects_distribution_tags;
+ @affects_distribution_tags{@{$config{affects_distribution_tags}}} =
+ (1) x @{$config{affects_distribution_tags}};
+ my $some_distributions_disallowed = 0;
+ my %allowed_distributions;
+ for my $tag (split ' ', ($status{tags}||'')) {
+ if (exists $affects_distribution_tags{$tag}) {
+ $some_distributions_disallowed = 1;
+ $allowed_distributions{$tag} = 1;
+ }
+ }
foreach my $arch (make_list($param{arch})) {
- my @versions;
for my $package (split /\s*,\s*/, $status{package}) {
+ my @versions;
foreach my $dist (make_list($param{dist})) {
+ # if some distributions are disallowed,
+ # and this isn't an allowed
+ # distribution, then we ignore this
+ # distribution for the purposees of
+ # finding versions
+ if ($some_distributions_disallowed and
+ not exists $allowed_distributions{$dist}) {
+ next;
+ }
push @versions, getversions($package, $dist, $arch);
}
+ next unless @versions;
my @temp = makesourceversions($package,
$arch,
@versions
my $maxbuggy = 'undef';
if (@sourceversions) {
$maxbuggy = max_buggy(bug => $param{bug},
- sourceversions => \@sourceversions,
- found => $status{found_versions},
- fixed => $status{fixed_versions},
- package => $status{package},
- version_cache => $version_cache,
- );
+ sourceversions => \@sourceversions,
+ found => $status{found_versions},
+ fixed => $status{fixed_versions},
+ package => $status{package},
+ version_cache => $version_cache,
+ );
}
elsif (defined $param{dist} and
not exists $pseudo_desc->{$status{package}}) {
man8_dir := $(man_dir)/man8
examples_dir := $(doc_dir)/examples
-scripts_in := $(filter-out scripts/config scripts/errorlib scripts/text, $(wildcard scripts/*))
+scripts_in := $(foreach script, $(filter-out scripts/config scripts/errorlib scripts/text, $(wildcard scripts/*)),$(patsubst scripts/%,%,$(script)))
htmls_in := $(wildcard html/*.html.in)
cgis := $(wildcard cgi/*.cgi cgi/*.pl)
for dir in $(sbin_dir) $(etc_dir)/html $(etc_dir)/indices \
$(var_dir)/indices $(var_dir)/www/cgi $(var_dir)/www/db $(var_dir)/www/txt \
$(var_dir)/spool/lock $(var_dir)/spool/archive $(var_dir)/spool/incoming \
-$(var_dir)/spool/db-h $(scripts_dir) $(perl_dir) $(examples_dir) $(man8_dir); \
+$(var_dir)/spool/db-h $(scripts_dir) $(examples_dir) $(man8_dir); \
do test -d $$dir || $(install_exec) -d $$dir; done
-
+# we shouldn't ship db-h spool directories
# make db-h spool dirs if they don't exist
- cd $(var_dir)/spool/db-h; \
- for dir in $(shell seq -w 00 99); \
- do test -d $$dir || $(install_exec) -d $$dir; done
+# cd $(var_dir)/spool/db-h; \
+# for dir in $(shell seq -w 00 99); \
+# do test -d $$dir || $(install_exec) -d $$dir; done
# install the scripts
- $(foreach script,$(scripts_in), $(install_exec) $(script) $(scripts_dir)/$(script);)
+ $(foreach script,$(scripts_in), $(exec $(install_exec) $(script) $(scripts_dir)/$(script)))
$(install_data) scripts/errorlib $(scripts_dir)/errorlib
# install examples
$(install_data) misc/updateseqs $(var_dir)/spool
# install the templates
- $(foreach dir $(wildcard templates/*/*) $(install_exec) $(template_dir)/$(patsubst templates/%,%,$(dir)))
- $(foreach tmpl $(wildcard templates/*/*/*.tmpl) $(install_data) $(template_dir)/$(patsubst templates/%,%,$(tmpl)))
+ $(foreach dir, $(wildcard templates/*/*), $(exec -d $(install_exec) $(template_dir)/$(patsubst templates/%,%,$(dir))))
+ $(foreach tmpl, $(wildcard templates/*/*/*.tmpl), $(exec $(install_data) $(tmpl) $(template_dir)/$(patsubst templates/%,%,$(tmpl))))
.PHONY: test
\ No newline at end of file
WriteMakefile(FIRST_MAKEFILE => 'Makefile.perl',
PMLIBDIRS => ['Debbugs'],
+ EXE_FILES => ['bin/local-debbugs',
+ 'bin/add_bug_to_estraier',
+ ],
NAME => 'Debbugs',
VERSION => '2.4.2',
);
--- /dev/null
+#! /usr/bin/perl
+# local-debbugs is part of debbugs, and is released
+# under the terms of the GPL version 2, or any later version, at your
+# option. See the file README and COPYING for more information.
+# Copyright 2008 by Don Armstrong <don@donarmstrong.com>.
+
+
+use warnings;
+use strict;
+
+use Getopt::Long;
+use Pod::Usage;
+
+=head1 NAME
+
+local-debbugs - use a local mirror of debbugs
+
+=head1 SYNOPSIS
+
+ [options]
+
+ Options:
+ --mirror, -M update local mirror
+ --daemon, -D start the daemon
+ --search, -S run a search
+ --show, -s show a bug
+ --debug, -d debugging level (Default 0)
+ --help, -h display this help
+ --man, -m display manual
+
+=head1 OPTIONS
+
+=over
+
+=item B<--mirror, -M>
+
+Update the local mirror of debbugs bugs
+
+=item B<--daemon, -D>
+
+Start up the daemon on the configured local port to serve bugs which
+have been previously retried
+
+=item B<--search, -S>
+
+Cause the running daemon to show the pkgreport.cgi page corresponding
+to the search by invoking sensible-browser and an appropriate url
+
+=item B<--show, -s>
+
+Cause the running daemon to show the bugreport.cgi page corresponding
+to the bug by invoking sensible-browser and an appropriate url
+
+=item B<--port,-p>
+
+The port that the daemon is running on (or will be running on.)
+
+Defaults to the value of the currently running daemon, the value in
+the configuration file, or 8080 if nothing is set.
+
+=item B<--bugs-to-get>
+
+File which contains the set of bugs to get.
+Defaults to ~/.debbugs/bugs_to_get
+
+=item B<--debug, -d>
+
+Debug verbosity. (Default 0)
+
+=item B<--help, -h>
+
+Display brief useage information.
+
+=item B<--man, -m>
+
+Display this manual.
+
+=back
+
+=head1 EXAMPLES
+
+
+=cut
+
+
+use vars qw($DEBUG);
+
+use User;
+use Config::Simple;
+use File::Temp qw(tempdir);
+use Params::Validate qw(validate_with :types);
+use POSIX 'setsid';
+use Debbugs::Common qw(checkpid lockpid);
+
+my %options = (debug => 0,
+ help => 0,
+ man => 0,
+ verbose => 0,
+ quiet => 0,
+ detach => 1,
+ cgi_bin => '/var/lib/debbugs/www/cgi-bin',
+ css => '/var/lib/debbugs/www/bugs.css',
+ );
+
+my %option_defaults = (port => 8080,
+ debbugs_config => User->Home.'/.debbugs/debbugs_config',
+ mirror_location => User->Home.'/.debbugs/mirror/',
+ bugs_to_get => User->Home.'/.debbugs/bugs_to_get',
+ );
+
+GetOptions(\%options,
+ 'daemon|D','show|s','search|select|S','mirror|M', 'stop',
+ 'detach!',
+ 'css=s','cgi_bin|cgi-bin|cgi=s',
+ 'verbose|v+','quiet|q+',
+ 'debug|d+','help|h|?','man|m');
+
+pod2usage() if $options{help};
+pod2usage({verbose=>2}) if $options{man};
+
+$DEBUG = $options{debug};
+
+my @USAGE_ERRORS;
+if (1 != grep {exists $options{$_}} qw(daemon show search mirror stop)) {
+ push @USAGE_ERRORS,"You must pass one (and only one) of --daemon --show --search or --mirror";
+}
+$options{verbose} = $options{verbose} - $options{quiet};
+
+pod2usage(join("\n",@USAGE_ERRORS)) if @USAGE_ERRORS;
+
+
+# munge in local configuration
+
+local_config(\%options);
+
+if ($options{daemon}) {
+ # daemonize, do stuff
+ my $pid = checkpid($options{mirror_location}.'/local-debbugs.pid');
+ if (defined $pid and $pid != 0) {
+ print STDERR "Unable to start daemon; it's already running\n";
+ exit 1;
+ }
+ if (-e $options{mirror_location}.'/local-debbugs.pid' and
+ not defined $pid) {
+ print STDERR "Unable to determine if daemon is running: $!\n";
+ exit 1;
+ }
+ # ok, now lets daemonize
+
+ # XXX make sure that all paths have been turned into absolute
+ # paths
+ chdir '/' or die "Can't chdir to /: $!";
+ # allow us not to detach for debugging
+ if ($options{detach}) {
+ open STDIN, '/dev/null' or die "Can't read /dev/null: $!";
+ open STDOUT, '>/dev/null'
+ or die "Can't write to /dev/null: $!";
+ defined(my $pid = fork) or die "Can't fork: $!";
+ exit if $pid;
+ setsid or die "Can't start a new session: $!";
+ open STDERR, '>&STDOUT' or die "Can't dup stdout: $!";
+ }
+ lockpid($options{mirror_location}.'/local-debbugs.pid') or
+ die "Unable to deal with the pidfile";
+ # this is the subclass of HTTP::Server::Simple::CGI which handles
+ # the "hard" bits of actually running a tiny webserver for us
+ {
+ package local_debbugs::server;
+ use IO::File;
+ use HTTP::Server::Simple;
+ use base qw(HTTP::Server::Simple::CGI);
+
+ sub net_server {
+ return 'Net::Server::Fork';
+ }
+
+ sub redirect {
+ my ($cgi,$url) = @_;
+ print "HTTP/1.1 302 Found\r\n";
+ print "Location: $url\r\n";
+ }
+
+ # here we want to call cgi-bin/pkgreport or cgi-bin/bugreport
+ sub handle_request {
+ my ($self,$cgi) = @_;
+
+ my $base_uri = 'http://'.$cgi->virtual_host;
+ if ($cgi->virtual_port ne 80) {
+ $base_uri .= ':'.$cgi->virtual_port;
+ }
+ my $path = $cgi->path_info();
+ # RewriteRule ^/[[:space:]]*#?([[:digit:]][[:digit:]][[:digit:]]+)([;&].+)?$ /cgi-bin/bugreport.cgi?bug=$1$2 [L,R,NE]
+ if ($path =~ m{^/?\s*\#?(\d+)((?:[;&].+)?)$}) {
+ redirect($cgi,$base_uri."/cgi-bin/bugreport.cgi?bug=$1$2");
+ }
+ # RewriteRule ^/[Ff][Rr][Oo][Mm]:([^/]+\@.+)$ /cgi-bin/pkgreport.cgi?submitter=$1 [L,R,NE]
+ elsif ($path =~ m{^/?\s*from:([^/]+\@.+)$}i) {
+ redirect($cgi,$base_uri."/cgi-bin/pkgreport.cgi?submitter=$1");
+ }
+ # RewriteRule ^/([^/]+\@.+)$ /cgi-bin/pkgreport.cgi?maint=$1 [L,R,NE]
+ elsif ($path =~ m{^/?\s*([^/]+\@.+)$}i) {
+ redirect($cgi,$base_uri."/cgi-bin/pkgreport.cgi?maint=$1");
+ }
+ # RewriteRule ^/mbox:([[:digit:]][[:digit:]][[:digit:]]+)([;&].+)?$ /cgi-bin/bugreport.cgi?mbox=yes&bug=$1$2 [L,R,NE]
+ elsif ($path =~ m{^/?\s*mbox:\#?(\d+)((?:[;&].+)?)$}i) {
+ redirect($cgi,$base_uri."/cgi-bin/bugreport.cgi?mbox=yes;bug=$1$2");
+ }
+ # RewriteRule ^/src:([^/]+)$ /cgi-bin/pkgreport.cgi?src=$1 [L,R,NE]
+ elsif ($path =~ m{^/?src:([^/]+)$}i) {
+ redirect($cgi,$base_uri."/cgi-bin/pkgreport.cgi?src=$1");
+ }
+ # RewriteRule ^/severity:([^/]+)$ /cgi-bin/pkgreport.cgi?severity=$1 [L,R,NE]
+ elsif ($path =~ m{^/?severity:([^/]+)$}i) {
+ redirect($cgi,$base_uri."/cgi-bin/pkgreport.cgi?severity=$1");
+ }
+ # RewriteRule ^/tag:([^/]+)$ /cgi-bin/pkgreport.cgi?tag=$1 [L,R,NE]
+ elsif ($path =~ m{^/?tag:([^/]+)$}i) {
+ redirect($cgi,$base_uri."/cgi-bin/pkgreport.cgi?tag=$1");
+ }
+ # RewriteRule ^/([^/]+)$ /cgi-bin/pkgreport.cgi?pkg=$1 [L,R,NE]
+ elsif ($path =~ m{^/?([^/]+)$}i) {
+ redirect($cgi,$base_uri."/cgi-bin/pkgreport.cgi?pkg=$1");
+ }
+ elsif ($path =~ m{^/?cgi(?:-bin)?/((?:(?:bug|pkg)report|version)\.cgi)}) {
+ # dispatch to pkgreport.cgi
+ print "HTTP/1.1 200 OK\n";
+ exec("$options{cgi_bin}/$1") or
+ die "Unable to execute $options{cgi_bin}/$1";
+ }
+ elsif ($path =~ m{^/?css/bugs.css}) {
+ my $fh = IO::File->new($options{css},'r') or
+ die "Unable to open $options{css} for reading: $!";
+ print "HTTP/1.1 200 OK\n";
+ print "Content-type: text/css\n";
+ print "\n";
+ print <$fh>;
+ }
+ elsif ($path =~ m{^/?$}) {
+ redirect($cgi,$base_uri."/cgi-bin/pkgreport.cgi?package=put%20package%20here");
+ }
+ else {
+ print "HTTP/1.1 404 Not Found\n";
+ print "Content-Type: text/html\n";
+ print "\n";
+ print "<h1>That which you were seeking, found I have not.</h1>\n";
+ }
+ # RewriteRule ^/$ /Bugs/ [L,R,NE]
+ }
+ }
+ my $debbugs_server = local_debbugs::server->new($options{port}) or
+ die "Unable to create debbugs server";
+ $debbugs_server->run() or
+ die 'Unable to run debbugs server';
+}
+elsif ($options{stop}) {
+ # stop the daemon
+ my $pid = checkpid($options{mirror_location}.'/local-debbugs.pid');
+ if (not defined $pid or $pid == 0) {
+ print STDERR "Unable to open pidfile or daemon not running: $!\n";
+ exit 1;
+ }
+ exit !(kill(15,$pid) == 1);
+}
+elsif ($options{mirror}) {
+ # run the mirror jobies
+ # figure out which bugs we need
+ my @bugs = select_bugs(\%options);
+ # get them
+ my $tempdir = tempdir(CLEANUP => 1);
+ my $mirror_log = IO::File->new($options{mirror_location}.'/mirror.log') or
+ die "Unable to open $options{mirror_location}/mirror.log for writing: $!";
+ my $inc_fh = IO::File->new("$tempdir/include_list",'w') or
+ die "Unable to open $tempdir/include_list for writing: $!";
+ foreach my $bug (@bugs) {
+ print {$inc_fh} "*/${bug}.*\n" or
+ die "Unable to write to $tempdir/include_list: $!";
+ }
+ close $inc_fh or
+ die "Unable to close $tempdir/include_list: $!";
+ my ($wrf,$rfh);
+ my @common_rsync_options = ('-avz','--partial');
+ print "Rsyncing bugs\n" if not $options{quiet};
+ run_rsync(log => $mirror_log,
+ ($options{debug}?(debug => \*STDERR):()),
+ options => [@common_rsync_options,
+ '--delete-after',
+ '--include-from',"$tempdir/include_list",
+ # skip things not specifically included
+ '--exclude','*/*',
+ # skip the -1,-2,-3.log files
+ '--exclude','*.log',
+ 'rsync://'.$options{bug_mirror}.'/bts-spool-db/',
+ $options{mirror_location}.'/db-h/']
+ );
+ print "Rsyncing archived bugs\n" if $options{verbose};
+ run_rsync(log => $mirror_log,
+ ($options{debug}?(debug => \*STDERR):()),
+ options => [@common_rsync_options,
+ '--delete-after',
+ '--include-from',"$tempdir/include_list",
+ # skip things not specifically included
+ '--exclude','*/*',
+ # skip the -1,-2,-3.log files
+ '--exclude','*.log',
+ 'rsync://'.$options{bug_mirror}.'/bts-spool-archive/',
+ $options{mirror_location}.'/archive/',
+ ],
+ );
+ print "Rsyncing indexes\n" if $options{verbose};
+ run_rsync(log => $mirror_log,
+ ($options{debug}?(debug => \*STDERR):()),
+ options => [@common_rsync_options,
+ '--exclude','*old',
+ '--exclude','*.bak',
+ '--exclude','by-reverse*',
+ 'rsync://'.$options{bug_mirror}.'/bts-spool-index/',
+ $options{mirror_location}.'/',
+ ],
+ );
+ print "Rsyncing versions\n" if $options{verbose};
+ run_rsync(log => $mirror_log,
+ ($options{debug}?(debug => \*STDERR):()),
+ options => [@common_rsync_options,
+ '--delete-after',
+ '--exclude','*old',
+ '--exclude','*.bak',
+ 'rsync://'.$options{bug_mirror}.'/bts-spool-versions/',
+ $options{mirror_location}.'/versions/',
+ ],
+ );
+}
+elsif ($options{show}) {
+ # figure out the url
+ # see if the daemon is running
+ my $pid = checkpid($options{mirror_location}.'/local-debbugs.pid');
+ if (not defined $pid or $pid == 0) {
+ print STDERR "Unable to open pidfile or daemon not running: $!\n";
+ print STDERR qq(Mr. T: "I pity da fool who tries to show a bug without a running daemon"\n);
+ print STDERR "Hint: try the --daemon option first\n";
+ exit 1;
+ }
+ # twist and shout
+ my $url = qq(http://localhost:$options{port}/$ARGV[0]);
+ exec('/usr/bin/sensible-browser',$url) or
+ die "Unable to run sensible-browser (try feeding me cheetos?)";
+}
+elsif ($options{search}) {
+ my $url = qq(http://localhost:$options{port}/cgi-bin/pkgreport.cgi?).
+ join(';',map {if (/:/) {s/:/=/; $_;} else {qq(pkg=$_);}} @ARGV);
+ my $pid = checkpid($options{mirror_location}.'/local-debbugs.pid');
+ if (not defined $pid or $pid == 0) {
+ print STDERR "Unable to open pidfile or daemon not running: $!\n";
+ print STDERR qq(Mr. T: "I pity da fool who tries to show a bug without a running daemon"\n);
+ print STDERR "Hint: try the --daemon option first\n";
+ exit 1;
+ }
+ # twist and shout
+ exec('/usr/bin/sensible-browser',$url) or
+ die "Unable to run sensible-browser (Maybe chorizo is required?)";
+}
+else {
+ # you get here, you were an idiot in checking for @USAGE_ERRORS
+ # above
+ die "No option that we understand was passed (the first check for this is now buggy, so shoot your maintainer)"
+}
+
+
+# determine the local configuration
+sub local_config{
+ my ($options) = @_;
+ my $config = {};
+ if (-e '/etc/debbugs/local_debbugs.conf') {
+ Config::Simple->import_from('/etc/debbugs/local_debbugs.conf', $config) or
+ die "Unable to read configuration from /etc/debbugs/local_debbugs.conf: $!";
+ }
+ if (-e User->Home.'/.debbugs/local_debbugs.conf') {
+ Config::Simple->import_from(User->Home.'/.debbugs/local_debbugs.conf', $config) or
+ die "Unable to read configuration from ".User->Home.'/.debbugs/local_debbugs.conf: '.$!;
+ }
+ for (keys %option_defaults) {
+ if (exists $config->{$_} and not defined $options->{$_}) {
+ $options->{$_} = $config->{$_};
+ }
+ if (not defined $options->{$_}) {
+ $options->{$_} = $option_defaults{$_};
+ }
+ }
+}
+
+# actually run rsync with the passed options
+sub run_rsync{
+ my %param = validate_with(params => \@_,
+ spec => {log => {type => HANDLE,
+ },
+ debug => {type => HANDLE,
+ optional => 1,
+ },
+ options => {type => ARRAYREF,
+ },
+ }
+ );
+ my ($output_fh,@rsync_options) = @_;
+ my ($wfh,$rfh);
+ my $pid = open3($wfh,$rfh,
+ 'rsync',
+ @{$param{options}}
+ ) or die "Unable to start rsync: $!";
+ close $wfh or die "Unable to close the writer filehandle $?";
+ while (<$rfh>) {
+ print {$param{log}} $_;
+ if (exists $param{debug}) {
+ print {$param{debug}} $_;
+ }
+ }
+}
+
+
+
+# select a set of bugs
+sub select_bugs{
+ my ($options) = @_;
+
+ my %valid_keys = (package => 'package',
+ pkg => 'package',
+ src => 'src',
+ source => 'src',
+ maint => 'maint',
+ maintainer => 'maint',
+ submitter => 'submitter',
+ from => 'submitter',
+ status => 'status',
+ tag => 'tag',
+ tags => 'tag',
+ usertag => 'tag',
+ usertags => 'tag',
+ owner => 'owner',
+ dist => 'dist',
+ distribution => 'dist',
+ bugs => 'bugs',
+ archive => 'archive',
+ severity => 'severity',
+ correspondent => 'correspondent',
+ affects => 'affects',
+ );
+
+ my $soap = SOAP::Lite
+ -> uri('Debbugs/SOAP/V1')
+ -> proxy("http://$options{bug_mirror}/cgi-bin/soap.cgi");
+ my @bugs;
+ my @bug_selections = ();
+ if (not -e $options{bugs_to_get}) {
+ my ($addr) = get_addresses(exists $ENV{DEBEMAIL}?
+ $ENV{DEBEMAIL} :
+ (User->Login . '@' . qx(hostname --fqdn)));
+ # by default include bugs talked to by this user packages
+ # maintained by this user, submitted by this user, and rc
+ # bugs
+ push @bug_selections,
+ ("correspondent:$addr archive:both",
+ "maint:$addr archive:both",
+ "submitter:$addr archive:both",
+ "severity:serious severity:grave severity:critical archive:both",
+ );
+ }
+ else {
+ my $btg_fh = IO::File->new($options{bugs_to_get},'r') or
+ die "unable to open bugs to get file '$options{bugs_to_get}' for reading: $!";
+ while (<$btg_fh>) {
+ chomp;
+ next if /^\s*#/;
+ if (/^\d+$/) {
+ push @bugs,$_;
+ }
+ elsif (/\s\w+\:/) {
+ push @bug_selections, $_;
+ }
+ }
+ }
+ for my $selection (@bug_selections) {
+ my @subselects = split /\s+/,$selection;
+ my %search_parameters;
+ my %users;
+ for my $subselect (@subselects) {
+ my ($key,$value) = split /:/, $subselect, 2;
+ next unless $key;
+ if (exists $valid_keys{$key}) {
+ push @{$search_parameters{$valid_keys{$key}}},
+ $value if $value;
+ } elsif ($key =~/users?$/) {
+ $users{$value} = 1 if $value;
+ }
+ }
+ my %usertags;
+ for my $user (keys %users) {
+ my $ut = $soap->get_usertag($user)->result();
+ next unless defined $ut and $ut ne "";
+ for my $tag (keys %{$ut}) {
+ push @{$usertags{$tag}},
+ @{$ut->{$tag}};
+ }
+ }
+ my $bugs = $soap->get_bugs(%search_parameters,
+ (keys %usertags)?(usertags=>\%usertags):()
+ )->result();
+ push @bugs,@{$bugs} if defined $bugs and @{$bugs};
+ }
+ return @bugs;
+}
+
+
+__END__
'&version_url' => \&Debbugs::CGI::version_url,
'&bug_url' => \&Debbugs::CGI::bug_url,
'&strftime' => \&POSIX::strftime,
- }
+ '&maybelink' => \&Debbugs::CGI::maybelink,
+ },
);
--- /dev/null
+#!/usr/bin/perl
+
+require './common.pl';
+
+require '/etc/debbugs/config';
+
+%map= ($gMirrors);
+
+my %in = readparse();
+
+if ($in{'type'} eq 'ref') {
+ $_= $in{'ref'};
+ s/^\s+//; s/^\#//; s/^\s+//; s/^0*//; s/\s+$//;
+
+ if (m/\D/ || !m/\d/) {
+ print <<END;
+Content-Type: text/html
+
+<html><head><title>Bug number not numeric</title>
+</head><body>
+<h1>Invalid input to specific bug fetch form</h1>
+
+You must type a number, being the bug reference number.
+There should be no nondigits in your entry.
+</html>
+END
+ exit(0);
+ }
+ $suburl= "bugreport.cgi?bug=$_";
+} elsif ($in{'type'} eq 'package') {
+ $_= $in{'package'};
+ s/^\s+//; s/\s+$//; y/A-Z/a-z/;
+ if (m/^[^0-9a-z]/ || m/[^-+.0-9a-z]/) {
+ print <<END;
+Content-Type: text/html
+
+<html><head><title>Package name contains invalid characters</title>
+</head><body>
+<h1>Invalid input to package buglist fetch form</h1>
+
+You must type a package name. Package names start with a letter
+or digit and contain only letters, digits and the characters
+- + . (hyphen, plus, full stop).
+</html>
+END
+ exit(0);
+ }
+ $suburl= "pkgreport.cgi?pkg=$_";
+} else {
+ print <<END;
+Content-Type: text/plain
+
+Please use the real DBC_WHO form. (invalid type value)
+END
+ exit(0);
+}
+
+$base= $gCGIDomain;
+
+$newurl= "http://$base/$suburl";
+print <<END;
+Status: 301 Redirect
+Location: $newurl
+
+The bug report data you are looking for ($suburl)
+is available <A href="$newurl">here</A>.
+
+(If this link does not work then the bug or package does not exist in
+the tracking system any more, or does not yet, or never did.)
+END
+
+exit(0);
+++ /dev/null
-#!/usr/bin/perl
-
-require './common.pl';
-
-require '/etc/debbugs/config';
-
-%map= ($gMirrors);
-
-my %in = readparse();
-
-if ($in{'type'} eq 'ref') {
- $_= $in{'ref'};
- s/^\s+//; s/^\#//; s/^\s+//; s/^0*//; s/\s+$//;
-
- if (m/\D/ || !m/\d/) {
- print <<END;
-Content-Type: text/html
-
-<html><head><title>Bug number not numeric</title>
-</head><body>
-<h1>Invalid input to specific bug fetch form</h1>
-
-You must type a number, being the bug reference number.
-There should be no nondigits in your entry.
-</html>
-END
- exit(0);
- }
- $suburl= "bugreport.cgi?bug=$_";
-} elsif ($in{'type'} eq 'package') {
- $_= $in{'package'};
- s/^\s+//; s/\s+$//; y/A-Z/a-z/;
- if (m/^[^0-9a-z]/ || m/[^-+.0-9a-z]/) {
- print <<END;
-Content-Type: text/html
-
-<html><head><title>Package name contains invalid characters</title>
-</head><body>
-<h1>Invalid input to package buglist fetch form</h1>
-
-You must type a package name. Package names start with a letter
-or digit and contain only letters, digits and the characters
-- + . (hyphen, plus, full stop).
-</html>
-END
- exit(0);
- }
- $suburl= "pkgreport.cgi?pkg=$_";
-} else {
- print <<END;
-Content-Type: text/plain
-
-Please use the real DBC_WHO form. (invalid type value)
-END
- exit(0);
-}
-
-$base= $gCGIDomain;
-
-$newurl= "http://$base/$suburl";
-print <<END;
-Status: 301 Redirect
-Location: $newurl
-
-The bug report data you are looking for ($suburl)
-is available <A href="$newurl">here</A>.
-
-(If this link does not work then the bug or package does not exist in
-the tracking system any more, or does not yet, or never did.)
-END
-
-exit(0);
next unless exists $param{$incexc};
$param{$incexc} = [grep /\S\:\S/, make_list($param{$incexc})];
}
+ # kill off keys for which empty values are meaningless
+ for my $key (qw(package src submitter severity status dist)) {
+ next unless exists $param{$key};
+ $param{$key} = [grep {length $_} make_list($param{$key})];
+ }
print $q->redirect(munge_url('pkgreport.cgi?',%param));
exit 0;
}
$param{archive} = 1;
}
+# fixup dist
+if (exists $param{dist} and $param{dist} eq '') {
+ delete $param{dist};
+}
my $include = $param{'&include'} || $param{'include'} || "";
my $exclude = $param{'&exclude'} || $param{'exclude'} || "";
my $maxdays = ($param{'maxdays'} || -1);
my $mindays = ($param{'mindays'} || 0);
my $version = $param{'version'} || undef;
-# XXX Once the options/selection is rewritten, this should go away
-my $dist = $param{dist} || undef;
+
our %hidden = map { $_, 1 } qw(status severity classification);
our %cats = (
next unless exists $param{$key};
my @entries = ();
$param{$key} = [map {split /\s*,\s*/} make_list($param{$key})];
- for my $entry (make_list($param{$key})) {
+ for my $entry (grep {defined $_ and length $_ } make_list($param{$key})) {
my $extra = '';
if (exists $param{dist} and ($key eq 'package' or $key eq 'src')) {
my %versions = get_versions(package => $entry,
}
push @entries, $entry.$extra;
}
- push @title,$value.' '.join(' or ', @entries);
+ push @title,$value.' '.join(' or ', @entries) if @entries;
}
my $title = $gBugs.' '.join(' and ', map {/ or /?"($_)":$_} @title);
@title = ();
-/etc/debbugs/html/Access.html.in
-/etc/debbugs/html/Developer.html.in
-/etc/debbugs/html/Reporting.html.in
-/etc/debbugs/html/index.html.in
-/etc/debbugs/html/server-control.html.in
-/etc/debbugs/html/server-refcard.html.in
-/etc/debbugs/html/server-request.html.in
Maintainer: Debbugs developers <debian-debbugs@lists.debian.org>
Uploaders: Josip Rodin <joy-packages@debian.org>, Colin Watson <cjwatson@debian.org>, Don Armstrong <don@debian.org>
Standards-Version: 3.2.1
-Build-Depends-Indep: debhelper, libparams-validate-perl, libmailtools-perl, libmime-perl, libio-stringy-perl, libmldbm-perl, liburi-perl, libsoap-lite-perl, libcgi-simple-perl, libhttp-server-simple-perl, libtest-www-mechanize-perl, libmail-rfc822-address-perl, libsafe-hole-perl
+Build-Depends-Indep: debhelper, libparams-validate-perl,
+ libmailtools-perl, libmime-perl, libio-stringy-perl, libmldbm-perl,
+ liburi-perl, libsoap-lite-perl, libcgi-simple-perl,
+ libhttp-server-simple-perl, libtest-www-mechanize-perl,
+ libmail-rfc822-address-perl, libsafe-hole-perl, libuser-perl,
+ libconfig-simple-perl
Package: debbugs
Architecture: all
-Depends: ${perl:Depends}, exim4 | mail-transport-agent, libdebbugs-perl, libmail-rfc822-address-perl
+Depends: ${perl:Depends}, exim4 | mail-transport-agent,
+ libdebbugs-perl
Recommends: debbugs-web
Suggests: spamassassin (>= 3.0), libcgi-alert-perl
Description: The bug tracking system based on the active Debian BTS
Package: libdebbugs-perl
Architecture: all
-Depends: ${perl:Depends}, libmailtools-perl, ed, libmime-perl, libio-stringy-perl, libmldbm-perl, liburi-perl, libsoap-lite-perl, libcgi-simple-perl, libparams-validate-perl, libtext-template-perl, libsafe-hole-perl
+Depends: ${perl:Depends}, libmailtools-perl, ed, libmime-perl,
+ libio-stringy-perl, libmldbm-perl, liburi-perl, libsoap-lite-perl,
+ libcgi-simple-perl, libparams-validate-perl, libtext-template-perl,
+ libsafe-hole-perl, libmail-rfc822-address-perl
Description: modules used by the active Debian BTS
Debian has a bug tracking system which files details of bugs reported by
users and developers. Each bug is given a number, and is kept on file until
.
This package contains the cgi scripts necessary to view bugreports
using the web.
+
+Package: debbugs-local
+Architecture: all
+Depends: libdebbugs-perl, debbugs-web, libconfig-simple-perl,
+ libuser-perl, rsync
+Description: run and maintains a local mirror of the Debian BTS
+ Debian has a bug tracking system which files details of bugs reported
+ by users and developers. Each bug is given a number, and is kept on
+ file until it is marked as having been dealt with. The system is
+ mainly controlled by e-mail, but the bug reports can be viewed using
+ the WWW.
+ .
+ This package contains extra scripts necessary to create a local
+ mirror of the Debian BTS and keep a local mirror up to date.
--- /dev/null
+usr/bin/local-debbugs
+usr/share/man/man1/local-debbugs*
--- /dev/null
+/etc/debbugs/html/Access.html.in
+/etc/debbugs/html/Developer.html.in
+/etc/debbugs/html/Reporting.html.in
+/etc/debbugs/html/index.html.in
+/etc/debbugs/html/server-control.html.in
+/etc/debbugs/html/server-refcard.html.in
+/etc/debbugs/html/server-request.html.in
usr/share/man/man8
usr/sbin
usr/share/doc/debbugs/examples
-var/lib/debbugs
\ No newline at end of file
+var/lib/debbugs
+usr/bin/add_bug_to_estraier
+usr/share/man/man1/add_bug_*
# Call the test suite
$(PERL) Makefile.PL INSTALLDIRS=vendor
$(MAKE) -f Makefile.perl
- $(MAKE) test
+# $(MAKE) test
touch $@
clean:
binary-arch:
# nothing to do, as there aren't any architecture-dependent packages
-binary-indep:
+binary-indep: build install
dh_testdir
dh_testroot
dh_clean -k
PACKAGE CLEANUP
* Stop doing the .in -> foo translation
+ - We no longer do this
* Use ExtUtils::Makemaker instead of a custom makefile
+ - We use Makemaker for the easy perl bits
* More testing of modules so it's not so easy to break things
margin-top: 0px;
padding: 0;
border: 0;
- display: block;
+ display: inline;
}
.bugs li {
use Debbugs::Status qw(:versions);
use Debbugs::Config qw(:globals :config);
+use Debbugs::Control qw(append_action_to_log);
+
chdir( "$gSpoolDir" ) || die "chdir spool: $!\n";
#open(DEBUG,"> /tmp/debbugs.debug");
sub htmllog {
my ($whatobj,$whatverb,$where,$desc) = @_;
- my $hash = get_hashname($ref);
- open(AP,">>db-h/$hash/$ref.log") || die "opening db-h/$hash/$ref.log (lh): $!";
- print(AP
- "\6\n".
- "<strong>$whatobj $whatverb</strong>".
- ($where eq '' ? "" : " to <code>".html_escape($where)."</code>").
- ":<br>\n". $desc.
- "\n\3\n") || die "writing db-h/$hash/$ref.log (lh): $!";
- close(AP) || die "closing db-h/$hash/$ref.log (lh): $!";
-}
+ append_action_to_log(bug => $ref,
+ action => "$whatobj $whatverb",
+ requester => '',
+ request_addr => $where,
+ desc => $desc,
+ get_lock => 0,
+ );
+}
sub stripbccs {
my $msg = shift;
Debbugs::User::read_usertags(\%ut, $user);
my @oldtags = (); my @newtags = (); my @badtags = ();
my %chtags;
- for my $t (split /[,\s]+/, $tags) {
- if ($t =~ m/^[a-zA-Z0-9.+\@-]+$/) {
- $chtags{$t} = 1;
- } else {
- push @badtags, $t;
- }
+ if (defined $tags and length $tags) {
+ for my $t (split /[,\s]+/, $tags) {
+ if ($t =~ m/^[a-zA-Z0-9.+\@-]+$/) {
+ $chtags{$t} = 1;
+ } else {
+ push @badtags, $t;
+ }
+ }
}
if (@badtags) {
print {$transcript} "Ignoring illegal tag/s: ".join(', ', @badtags).".\nPlease use only alphanumerics, at, dot, plus and dash.\n";
}
{$log}
<hr>
-<p class="msgreceived">Send a report that <a href="{$config{cgi_domain}}/bugspam.cgi">this bug log contains spam</a>.</p>
+<p class="msgreceived">Send a report that <a href="http://{$config{cgi_domain}}/bugspam.cgi">this bug log contains spam</a>.</p>
<hr>
{include(q(html/html_tail))}
</body>
$output .= q(<p>Bug is archived. No further changes may be made.<p>)
}
$output
+}{ my $output = '';
+ if (length($status{forwarded})) {
+ $output = "<p>Forwarded to " .
+ join(', ',
+ map {maybelink($_)}
+ split /\,\s+/,$status{forwarded}
+ )."</p>\n";
+ }
+ $output;
}{ my $output = '';
if (exists $status{summary} and defined $status{summary} and length $status{summary}) {
$output .= q(<p>Summary: ).html_escape($status{summary}).q(</p>);
<input type="checkbox" name="bug-rev" {exists $param{"bug-rev"} and $param{"bug-rev"}?' checked':''}> Reverse Bugs<br>
<input type="checkbox" name="pend-rev" {exists $param{"pend-rev"} and $param{"pend-rev"}?' checked':''}> Reverse Pending<br>
<input type="checkbox" name="sev-rev" {exists $param{"sev-rev"} and $param{"sev-rev"}?' checked':''}> Reverse Severity<br>
+<select name="dist">
+{output_select_options(['' => 'None',
+ map {($_,$_)} @{$config{distributions}},
+ ],$param{dist}||'')
+}</select><br>
<select name="archive">
{output_select_options([0 => 'Unarchived',
1 => 'Archived',
projects / debbugs.git / commitdiff