--- /dev/null
+dist: trusty
+sudo: required
+before_install:
+ - sudo apt-get -qq update
+ - >
+ sudo apt-get install -y libparams-validate-perl
+ libmailtools-perl libmime-tools-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 libtest-pod-perl
+ liblist-allutils-perl libtext-template-perl graphviz
+ libfile-libmagic-perl libgravatar-url-perl libwww-perl imagemagick
+script:
+ - make; make test
+notifications:
+ irc:
+ channels:
+ - "irc.oftc.net#debbugs"
+ email: false
use Debbugs::Common qw(getparsedaddrs package_maintainer getmaintainers make_list hash_slice);
use Fcntl qw(O_RDONLY);
use MLDBM qw(DB_File Storable);
-use List::Util qw(first);
+use List::AllUtils qw(first);
use Carp;
=head2 get_bugs
use POSIX qw(ceil);
use Storable qw(dclone);
-use List::Util qw(max);
+use List::AllUtils qw(max);
use File::stat;
use Digest::MD5 qw(md5_hex);
use Carp;
sub quitcgi {
- my $msg = shift;
+ my ($msg, $status) = @_;
+ $status //= '500 Internal Server Error';
+ print "Status: $status\n";
print "Content-Type: text/html\n\n";
print fill_in_template(template=>'cgi/quit',
variables => {msg => $msg}
return htmlize_addresslinks($prefixfunc, \&mainturl, $maints);
}
-
-our $_maintainer;
-our $_maintainer_rev;
-
=head2 bug_linklist
bug_linklist($separator,$class,@bugs)
for my $key (keys %{$param{form_option}}) {
# strip out leader; shouldn't be anything here without one,
# but skip stupid things anyway
- my $o_key = $key;
next unless $key =~ s/^\Q$form_option_leader\E//;
if ($key =~ /^add_(.+)$/) {
# this causes a specific parameter to be added
use warnings;
use strict;
+use utf8;
use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
use Exporter qw(import);
use Encode qw(decode_utf8 encode_utf8);
use URI::Escape qw(uri_escape_utf8);
use Scalar::Util qw(blessed);
+use List::AllUtils qw(sum);
use File::Temp;
BEGIN{
my $output = globify_scalar($param{output});
my $entity = $param{entity};
my $ref = $param{bug_num};
- my $top = $param{outer};
my $xmessage = $param{msg_num};
my $attachments = $param{attachments};
my $body = $entity->bodyhandle->as_string;
$body = convert_to_utf8($body,$charset//'utf8');
$body = html_escape($body);
+ my $css_class = "message";
# Attempt to deal with format=flowed
if ($content_type =~ m/format\s*=\s*\"?flowed\"?/i) {
$body =~ s{^\ }{}mgo;
# we ignore the other things that you can do with
# flowed e-mails cause they don't really matter.
+ $css_class .= " flowed";
+ }
+
+ # if the message is composed entirely of lines which are separated by
+ # newlines, wrap it. [Allow the signature to have special formatting.]
+ if ($body =~ /^([^\n]+\n\n)*[^\n]*\n?(-- \n.+)*$/s or
+ # if the first 20 lines in the message which have any non-space
+ # characters are larger than 100 characters more often than they
+ # are not, then use CSS to try to impose sensible wrapping
+ sum(0,map {length ($_) > 100?1:-1} grep {/\S/} split /\n/,$body,20) > 0
+ ) {
+ $css_class .= " wrapping";
}
# Add links to URLs
# We don't html escape here because we escape above;
) {
# Add links to CVE vulnerabilities (closes #568464)
$body =~ s{(^|\s|[\(\[])(CVE-\d{4}-\d{4,})(\s|[,.-\[\]\)]|$)}
- {$1<a href="http://$config{cve_tracker}$2">$2</a>$3}gxm;
+ {$1<a href="$config{cve_tracker}$2">$2</a>$3}gxm;
}
if (not exists $param{att}) {
- print {$output} qq(<pre class="message">$body</pre>\n);
+ print {$output} qq(<pre class="$css_class">$body</pre>\n);
}
}
return 0;
# $record->{text} is not in perl's internal encoding; convert it
my $text = decode_rfc1522(decode_utf8(record_text($record)));
my ($time) = $text =~ /<!--\s+time:(\d+)\s+-->/;
- my $class = $text =~ /^<strong>(?:Acknowledgement|Reply|Information|Report|Notification)/m ? 'infmessage':'msgreceived';
+ my $class = $text =~ /^<strong>(?:Acknowledgement|Information|Report|Notification)/m ? 'infmessage':'msgreceived';
$output .= $text;
# Link to forwarded http:// urls in the midst of the report
# (even though these links already exist at the top)
# Add links to the cloned bugs
$output =~ s{(Bug )(\d+)( cloned as bugs? )(\d+)(?:\-(\d+)|)}{$1.bug_links(bug=>$2).$3.bug_links(bug=>(defined $5)?[$4..$5]:$4)}eo;
# Add links to merged bugs
- $output =~ s{(?<=Merged )([\d\s]+)(?=\.)}{join(' ',map {bug_links(bug=>$_)} (split /\s+/, $1))}eo;
+ $output =~ s{(?<=Merged )([\d\s]+)(?=[\.<])}{join(' ',map {bug_links(bug=>$_)} (split /\s+/, $1))}eo;
# Add links to blocked bugs
$output =~ s{(?<=Blocking bugs)(?:( of )(\d+))?( (?:added|set to|removed):\s+)([\d\s\,]+)}
{(defined $2?$1.bug_links(bug=>$2):'').$3.
(\d+(?:,\s+\d+)*(?:\,?\s+and\s+\d+)?)}
{$1.(defined $3?$2.bug_links(bug=>$3):'').$4.
english_join([map {bug_links(bug=>$_)} (split /\,?\s+(?:and\s+)?/, $5)])}xeo;
- $output =~ s{([Aa]dded|[Rr]emoved)( indication that bug )(\d+)( blocks )([\d\s\,]+)}
+ $output =~ s{([Aa]dded|[Rr]emoved)( indication that bug )(\d+)( blocks ?)([\d\s\,]+)}
{$1.$2.(bug_links(bug=>$3)).$4.
english_join([map {bug_links(bug=>$_)} (split /\,?\s+(?:and\s+)?/, $5)])}eo;
# Add links to reassigned packages
if (defined $time) {
$output .= ' ('.strftime('%a, %d %b %Y %T GMT',gmtime($time)).') ';
}
- $output .= '<a href="' .
+ $output .= qq{(<a href="} .
html_escape(bug_links(bug => $bug_number,
options => {msg => ($msg_number+1)},
links_only => 1,
)
- ) . '">
Full text</a> and <a href="' .
+ ) . '">
full text</a>, <a href="' .
html_escape(bug_links(bug => $bug_number,
options => {msg => ($msg_number+1),
mbox => 'yes'},
links_only => 1)
- ) . '">rfc822 format</a> available.';
+ ) . '">mbox</a>, '.
+ qq{<a href="#$msg_number">link</a>).</p>};
- $output = qq(<div class="$class"><hr>\n<a name="$msg_number"></a>\n) . $output . "</div>\n";
+ $output = qq(<div class="$class"><hr><p>\n<a name="$msg_number"></a>\n) . $output . "</p></div>\n";
}
elsif (/recips/) {
my ($msg_id) = record_regex($record,qr/^Message-Id:\s+<(.+)>/i);
elsif (defined $msg_id) {
$$seen_msg_ids{$msg_id} = 1;
}
- $output .= qq(<hr><p class="msgreceived"><a name="$msg_number"></a>\n);
+ return () if defined $param{spam} and $param{spam}->is_spam($msg_id);
+ $output .= qq(<hr><p class="msgreceived"><a name="$msg_number" href="#$msg_number">🔗</a>\n);
$output .= 'View this message in <a href="' . html_escape(bug_links(bug=>$bug_number, links_only => 1, options=>{msg=>$msg_number, mbox=>'yes'})) . '">rfc822 format</a></p>';
$output .= handle_email_message($record,
ref => $bug_number,
elsif (defined $msg_id) {
$$seen_msg_ids{$msg_id} = 1;
}
+ return () if defined $param{spam} and $param{spam}->is_spam($msg_id);
# Incomming Mail Message
my ($received,$hostname) = record_regex($record,qr/Received: \(at (\S+)\) by (\S+)\;/o);
$output .= qq|<hr><p class="msgreceived"><a name="$msg_number"></a><a name="msg$msg_number"></a><a href="#$msg_number">Message #$msg_number</a> received at |.
my @references;
my $pseudodesc = getpseudodesc();
if ($package and defined($pseudodesc) and exists($pseudodesc->{$package})) {
- push @references, "to the <a href=\"http://$config{web_domain}/pseudo-packages$config{html_suffix}\">".
+ push @references, "to the <a href=\"$config{web_domain}/pseudo-packages$config{html_suffix}\">".
"list of other pseudo-packages</a>";
}
elsif (not defined $maint and not @{$param{bugs}}) {
else {
if ($package and defined $config{package_pages} and length $config{package_pages}) {
push @references, sprintf "to the <a href=\"%s\">%s package page</a>",
- html_escape("http://$config{package_pages}/$package"), html_escape("$package");
+ html_escape("$config{package_pages}/$package"), html_escape("$package");
}
if (defined $config{subscription_domain} and
length $config{subscription_domain}) {
my $ptslink = $param{binary} ? $srcforpkg : $package;
# the pts only wants the source, and doesn't care about src: (#566089)
$ptslink =~ s/^src://;
- push @references, q(to the <a href="http://).html_escape("$config{subscription_domain}/$ptslink").q(">Package Tracking System</a>);
+ push @references, q(to the <a href=").html_escape("$config{package_tracking_domain}/$ptslink").q(">Package Tracking System</a>);
}
# Only output this if the source listing is non-trivial.
if ($param{binary} and $srcforpkg) {
if (defined $maint) {
print {$output} "<p>If you find a bug not listed here, please\n";
printf {$output} "<a href=\"%s\">report it</a>.</p>\n",
- html_escape("http://$config{web_domain}/Reporting$config{html_suffix}");
+ html_escape("$config{web_domain}/Reporting$config{html_suffix}");
}
return decode_utf8($output_scalar);
}
qw(getpseudodesc),
qw(package_maintainer),
qw(sort_versions),
+ qw(open_compressed_file),
],
misc => [qw(make_list globify_scalar english_join checkpid),
qw(cleanup_eval_fail),
die "Unable to rename ${file}.new to $file: $!";
}
+=head2 open_compressed_file
+ my $fh = open_compressed_file('foo.gz') or
+ die "Unable to open compressed file: $!";
+
+
+Opens a file; if the file ends in .gz, .xz, or .bz2, the appropriate
+decompression program is forked and output from it is read.
+
+This routine by default opens the file with UTF-8 encoding; if you want some
+other encoding, specify it with the second option.
+
+=cut
+sub open_compressed_file {
+ my ($file,$encoding) = @_;
+ $encoding //= ':encoding(UTF-8)';
+ my $fh;
+ my $mode = "<$encoding";
+ my @opts;
+ if ($file =~ /\.gz$/) {
+ $mode = "-|$encoding";
+ push @opts,'gzip','-dc';
+ }
+ if ($file =~ /\.xz$/) {
+ $mode = "-|$encoding";
+ push @opts,'xz','-dc';
+ }
+ if ($file =~ /\.bz2$/) {
+ $mode = "-|$encoding";
+ push @opts,'bzip2','-dc';
+ }
+ open($fh,$mode,@opts,$file);
+ return $fh;
+}
for my $fn (@config{('source_maintainer_file',
'source_maintainer_file_override',
'pseudo_maint_file')}) {
- next unless defined $fn;
+ next unless defined $fn and length $fn;
if (not -e $fn) {
warn "Missing source maintainer file '$fn'";
next;
for my $fn (@config{('maintainer_file',
'maintainer_file_override',
'pseudo_maint_file')}) {
- next unless defined $fn;
+ next unless defined $fn and length $fn;
if (not -e $fn) {
warn "Missing maintainer file '$fn'";
next;
}
$type //= 'address';
my $fh = IO::File->new($fn,'r') or
- die "Unable to open $fn for reading: $!";
+ croak "Unable to open $fn for reading: $!";
binmode($fh,':encoding(UTF-8)');
while (<$fh>) {
chomp;
return $_pseudodesc if defined $_pseudodesc;
$_pseudodesc = {};
__add_to_hash($config{pseudo_desc_file},$_pseudodesc) if
- defined $config{pseudo_desc_file};
+ defined $config{pseudo_desc_file} and
+ length $config{pseudo_desc_file};
return $_pseudodesc;
}
qw($gWebDomain $gHTMLSuffix $gCGIDomain $gMirrors),
qw($gPackagePages $gSubscriptionDomain $gProject $gProjectTitle),
qw($gMaintainer $gMaintainerWebpage $gMaintainerEmail $gUnknownMaintainerEmail),
+ qw($gPackageTrackingDomain $gUsertagPackageDomain),
qw($gSubmitList $gMaintList $gQuietList $gForwardList),
qw($gDoneList $gRequestList $gSubmitterList $gControlList),
qw($gStrongList),
=item web_domain $gWebDomain
-Full path of the web domain where bugs are kept, defaults to the
-concatenation of L</web_host> and L</web_host_bug_dir>
+Full path of the web domain where bugs are kept including the protocol (http://
+or https://). Defaults to the concatenation of 'http://', L</web_host> and
+L</web_host_bug_dir>
=cut
-set_default(\%config,'web_domain',$config{web_host}.($config{web_host}=~m{/$}?'':'/').$config{web_host_bug_dir});
+set_default(\%config,'web_domain','http://'.$config{web_host}.($config{web_host}=~m{/$}?'':'/').$config{web_host_bug_dir});
=item html_suffix $gHTMLSuffix
=item cgi_domain $gCGIDomain
Full path of the web domain where cgi scripts are kept. Defaults to
-the concatentation of L</web_host> and cgi.
+the concatentation of L</web_domain> and cgi.
=cut
=item package_pages $gPackagePages
Domain where the package pages are kept; links should work in a
-package_pages/foopackage manner. Defaults to undef, which means that
-package links will not be made.
+package_pages/foopackage manner. Defaults to undef, which means that package
+links will not be made. Should be prefixed with the appropriate protocol
+(http/https).
=cut
set_default(\%config,'package_pages',undef);
+=item package_tracking_domain $gPackageTrackingDomain
+
+Domain where the package pages are kept; links should work in a
+package_tracking_domain/foopackage manner. Defaults to undef, which means that
+package links will not be made. Should be prefixed with the appropriate protocol
+(http or https).
+
+=cut
+
+set_default(\%config,'package_tracking_domain',undef);
+
=item package_pages $gUsertagPackageDomain
Domain where where usertags of packages belong; defaults to $gPackagePages
=cut
-set_default(\%config,'usertag_package_domain',$config{package_pages});
+set_default(\%config,'usertag_package_domain',map {my $a = $_; defined $a?$a =~ s{https?://}{}:(); $a} $config{package_pages});
=item subscription_domain $gSubscriptionDomain
set_default(\%config,'subscription_domain',undef);
+=item cc_all_mails_to_addr $gCcAllMailsToAddr
+
+Address to Cc (well, Bcc) all e-mails to
+
+=cut
+
+set_default(\%config,'cc_all_mails_to_addr',undef);
+
+
=item cve_tracker $gCVETracker
URI to CVE security tracker; in bugreport.cgi, CVE-2001-0002 becomes
-linked to http://$config{cve_tracker}CVE-2001-002
+linked to $config{cve_tracker}CVE-2001-002
-Default: security-tracker.debian.org/tracker/
+Default: https://security-tracker.debian.org/tracker/
=cut
-set_default(\%config,'cve_tracker','security-tracker.debian.org/tracker/');
+set_default(\%config,'cve_tracker','https://security-tracker.debian.org/tracker/');
=back
For removal/archival purposes, all bugs are assumed to have these tags
set.
-Default: qw(unstable testing);
+Default: qw(experimental unstable testing);
=cut
set_default(\%config,'removal_default_distribution_tags',
- [qw(unstable testing)]
+ [qw(experimental unstable testing)]
);
=item removal_strong_severity_default_distribution_tags
For removal/archival purposes, all bugs with strong severity are
assumed to have these tags set.
-Default: qw(unstable testing stable);
+Default: qw(experimental unstable testing stable);
=cut
set_default(\%config,'removal_strong_severity_default_distribution_tags',
- [qw(unstable testing stable)]
+ [qw(experimental unstable testing stable)]
);
set_default(\%config,'sendmail_arguments',[qw(-oem -oi)]);
+=item envelope_from
+
+Envelope from to use for sent messages. If not set, whatever sendmail picks is
+used.
+
+=cut
+
+set_default(\%config,'envelope_from',undef);
+
=item spam_scan
Whether or not spamscan is being used; defaults to 0 (not being used
=cut
-set_default(\%config,'libravatar_uri','http://'.$config{cgi_domain}.'/libravatar.cgi?email=');
+set_default(\%config,'libravatar_uri',$config{cgi_domain}.'/libravatar.cgi?email=');
=item libravatar_uri_options $gLibravatarUriOptions
SUBSTITUTE_DTIME
<!--timestamp-->
<P>
- <A HREF=\"http://$config{web_domain}/\">Debian $config{bug} tracking system</A><BR>
+ <A HREF=\"$config{web_domain}/\">Debian $config{bug} tracking system</A><BR>
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.
+ </P>
</ADDRESS>
END
use POSIX qw(strftime);
use Storable qw(dclone nfreeze);
-use List::Util qw(first max);
+use List::AllUtils qw(first max);
use Encode qw(encode_utf8);
use Carp;
}
}
}
- my @new_blockers = keys %blockers;
for my $data (@data) {
my $old_data = dclone($data);
# remove blockers and/or add new ones as appropriate
$mungable_blocks{add} = \%added_blockers if keys %added_blockers;
my $new_locks = 0;
for my $add_remove (keys %mungable_blocks) {
- my @munge_blockers;
my %munge_blockers;
- my $block_locks = 0;
for my $blocker (keys %{$mungable_blocks{$add_remove}}) {
next if $munge_blockers{$blocker};
my ($temp_locks, @blocking_data) =
__begin_control(%param,
command => 'tag'
);
- my ($debug,$transcript) =
- @info{qw(debug transcript)};
+ my $transcript = $info{transcript};
my @data = @{$info{data}};
- my @bugs = @{$info{bugs}};
my @tags = make_list($param{tag});
if (not @tags and ($param{remove} or $param{add})) {
if ($param{remove}) {
my $action = 'Did not alter tags';
my %tag_added = ();
my %tag_removed = ();
- my %fixed_removed = ();
my @old_tags = split /\,?\s+/, $data->{keywords};
my %tags;
@tags{@old_tags} = (1) x @old_tags;
- my $reopened = 0;
my $old_data = dclone($data);
if (not $param{add} and not $param{remove}) {
$tag_removed{$_} = 1 for @old_tags;
__begin_control(%param,
command => 'severity'
);
- my ($debug,$transcript) =
- @info{qw(debug transcript)};
+ my $transcript = $info{transcript};
my @data = @{$info{data}};
- my @bugs = @{$info{bugs}};
my $action = '';
for my $data (@data) {
__begin_control(%param,
command => $param{reopen}?'reopen':'done',
);
- my ($debug,$transcript) =
- @info{qw(debug transcript)};
+ my $transcript = $info{transcript};
my @data = @{$info{data}};
- my @bugs = @{$info{bugs}};
my $action ='';
if ($param{reopen}) {
}
else {
my %submitter_notified;
- my $requester_notified = 0;
my $orig_report_set = 0;
for my $data (@data) {
if (exists $data->{done} and
my ($debug,$transcript) =
@info{qw(debug transcript)};
my @data = @{$info{data}};
- my @bugs = @{$info{bugs}};
my $action = '';
# here we only concern ourselves with the first of the merged bugs
for my $data ($data[0]) {
my ($debug,$transcript) =
@info{qw(debug transcript)};
my @data = @{$info{data}};
- my @bugs = @{$info{bugs}};
my $action = '';
for my $data (@data) {
my $old_data = dclone($data);
my ($debug,$transcript) =
@info{qw(debug transcript)};
my @data = @{$info{data}};
- my @bugs = @{$info{bugs}};
my $action = '';
for my $data (@data) {
my $old_data = dclone($data);
my ($debug,$transcript) =
@info{qw(debug transcript)};
my @data = @{$info{data}};
- my @bugs = @{$info{bugs}};
# clean up the new package
my $new_package =
join(',',
my ($debug,$transcript) =
@info{qw(debug transcript)};
my @data = @{$info{data}};
- my @bugs = @{$info{bugs}};
my %versions;
for my $version (make_list($param{found})) {
next unless defined $version;
my ($debug,$transcript) =
@info{qw(debug transcript)};
my @data = @{$info{data}};
- my @bugs = @{$info{bugs}};
my %versions;
for my $version (make_list($param{fixed})) {
next unless defined $version;
return;
}
my @data = @{$info{data}};
- my @bugs = @{$info{bugs}};
my %data;
my %merged_bugs;
for my $data (@data) {
# handle unmerging
my $new_locks = 0;
if (not exists $param{merge_with}) {
- my $ok_to_unmerge = 1;
delete $merged_bugs{$param{bug}};
if (not keys %merged_bugs) {
print {$transcript} "Ignoring request to unmerge a bug which is not merged with any others.\n";
$data->{mergedwith} = '';
}
else {
- $data->{mergedwith} = join(' ',sort grep {$_ != $data->{bug_num}}
- keys %merged_bugs);
+ $data->{mergedwith} =
+ join(' ',
+ sort {$a <=> $b}
+ grep {$_ != $data->{bug_num}}
+ keys %merged_bugs);
}
append_action_to_log(bug => $data->{bug_num},
command => 'merge',
return;
}
# lock and load all of the bugs we need
- my @bugs_to_load = keys %merging;
- my $bug_to_load;
- my %merge_added;
my ($data,$n_locks) =
__lock_and_load_merged_bugs(bugs_to_load => [keys %merging],
data => \@data,
my %target_blockedby;
@target_blockedby{@{$change->{func_value}}} = (1) x @{$change->{func_value}};
my %unhandled_targets = %target_blockedby;
- my @blocks_to_remove;
for my $key (split / /,$change->{orig_value}) {
delete $unhandled_targets{$key};
next if exists $target_blockedby{$key};
}
# finally, we can merge the bugs
- my $action = "Merged ".join(' ',sort keys %merged_bugs);
+ my $action = "Merged ".join(' ',sort { $a <=> $b } keys %merged_bugs);
for my $data (@data) {
my $old_data = dclone($data);
- $data->{mergedwith} = join(' ',sort grep {$_ != $data->{bug_num}}
- keys %merged_bugs);
+ $data->{mergedwith} =
+ join(' ',
+ sort { $a <=> $b }
+ grep {$_ != $data->{bug_num}}
+ keys %merged_bugs);
append_action_to_log(bug => $data->{bug_num},
command => 'merge',
new_data => $data,
my ($debug,$transcript) =
@info{qw(debug transcript)};
my @data = @{$info{data}};
- my @bugs = @{$info{bugs}};
my $action = '';
for my $data (@data) {
$action = '';
my ($debug,$transcript) =
@info{qw(debug transcript)};
my @data = @{$info{data}};
- my @bugs = @{$info{bugs}};
# figure out the log that we're going to use
my $summary = '';
my $summary_msg = '';
print {$debug} "Removing $cmd fields\n";
$action = "Removed $cmd";
}
- elsif ($param{$cmd} =~ /^\d+$/) {
+ elsif ($param{$cmd} =~ /^-?\d+$/) {
my $log = [];
my @records = Debbugs::Log::read_log_records(bug_num => $param{bug});
if ($param{$cmd} == 0 or $param{$cmd} == -1) {
__begin_control(%param,
command => 'clone'
);
- my ($debug,$transcript) =
- @info{qw(debug transcript)};
+ my $transcript = $info{transcript};
my @data = @{$info{data}};
- my @bugs = @{$info{bugs}};
my $action = '';
for my $data (@data) {
for my $bug (split ' ', $data->{blocks}) {
for my $new_bug (@new_bugs) {
set_blocks(bug => $bug,
- block => $new_bug,
+ block => $new_bug,
+ add => 1,
hash_slice(%param,
keys %common_options,
keys %append_action_options),
for my $bug (split ' ', $data->{blockedby}) {
for my $new_bug (@new_bugs) {
set_blocks(bug => $new_bug,
- block => $bug,
+ block => $bug,
+ add => 1,
hash_slice(%param,
keys %common_options,
keys %append_action_options),
my ($debug,$transcript) =
@info{qw(debug transcript)};
my @data = @{$info{data}};
- my @bugs = @{$info{bugs}};
my $action = '';
for my $data (@data) {
print {$debug} "Going to change owner to '".(defined $param{owner}?$param{owner}:'(going to unset it)')."'\n";
command=>'unarchive');
my ($debug,$transcript) =
@info{qw(debug transcript)};
- my @data = @{$info{data}};
my @bugs = @{$info{bugs}};
my $action = "$config{bug} unarchived.";
my @files_to_remove;
}
if (not $match) {
$going_to_fail = 1;
- print {$transcript} qq($field: ).join(', ',map{qq("$_")} make_list($data->{$field})).
+ print {$transcript} qq($field: ').join(', ',map{qq("$_")} make_list($data->{$field})).
"' does not match at least one of ".
join(', ',map {ref($_)?'(regex)':qq("$_")} make_list($param{limit}{$field}))."\n";
}
$extra_var ||={};
my $hole_var = {'&bugurl' =>
sub{"$_[0]: ".
- 'http://'.$config{cgi_domain}.'/'.
+ $config{cgi_domain}.'/'.
Debbugs::CGI::bug_links(bug => $_[0],
links_only => 1,
);
use Debbugs::Control qw(:all);
use Debbugs::Status qw(splitpackages);
use Params::Validate qw(:types validate_with);
-use List::Util qw(first);
+use List::AllUtils qw(first);
my $bug_num_re = '-?\d+';
my %control_grammar =
print {$transcript} "Failed to forcibly merge $ref: ".cleanup_eval_fail($@,$debug)."\n";
}
} elsif ($ctl eq 'clone') {
- my $origref = $matches[0];
my @newclonedids = split /\s+/, $matches[1];
- my $newbugsneeded = scalar(@newclonedids);
eval {
my %new_clones;
--- /dev/null
+# This module 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 2017 by Don Armstrong <don@donarmstrong.com>.
+
+package Debbugs::DebArchive;
+
+use warnings;
+use strict;
+
+=head1 NAME
+
+Debbugs::DebArchive -- Routines for reading files from Debian archives
+
+=head1 SYNOPSIS
+
+use Debbugs::DebArchive;
+
+ read_packages('/srv/mirrors/ftp.debian.org/ftp/dist',
+ sub { print map {qq($_\n)} @_ },
+ Term::ProgressBar->new(),
+ );
+
+
+=head1 DESCRIPTION
+
+This module implements a set of routines for reading Packages.gz, Sources.gz and
+Release files from the dists directory of a Debian archive.
+
+=head1 BUGS
+
+None known.
+
+=cut
+
+
+use vars qw($DEBUG $VERSION @EXPORT_OK %EXPORT_TAGS @EXPORT);
+use base qw(Exporter);
+
+BEGIN {
+ $VERSION = 1.00;
+ $DEBUG = 0 unless defined $DEBUG;
+
+ @EXPORT = ();
+ %EXPORT_TAGS = (read => [qw(read_release_file read_packages),
+ ],
+ );
+ @EXPORT_OK = ();
+ Exporter::export_ok_tags(keys %EXPORT_TAGS);
+ $EXPORT_TAGS{all} = [@EXPORT_OK];
+}
+
+use File::Spec qw();
+use File::Basename;
+use Debbugs::Config qw(:config);
+use Debbugs::Common qw(open_compressed_file make_list);
+use IO::Dir;
+
+use Carp;
+
+=over
+
+=item read_release_file
+
+ read_release_file('stable/Release')
+
+Reads a Debian release file and returns a hashref of information about the
+release file, including the Packages and Sources files for that distribution
+
+=cut
+
+sub read_release_file {
+ my ($file) = @_;
+ # parse release
+ my $rfh = open_compressed_file($file) or
+ die "Unable to open $file for reading: $!";
+ my %dist_info;
+ my $in_sha1;
+ my %p_f;
+ while (<$rfh>) {
+ chomp;
+ if (s/^(\S+):\s*//) {
+ if ($1 eq 'SHA1'or $1 eq 'SHA256') {
+ $in_sha1 = 1;
+ next;
+ }
+ $dist_info{$1} = $_;
+ } elsif ($in_sha1) {
+ s/^\s//;
+ my ($sha,$size,$f) = split /\s+/,$_;
+ next unless $f =~ /(?:Packages|Sources)(?:\.gz|\.xz)$/;
+ next unless $f =~ m{^([^/]+)/([^/]+)/([^/]+)$};
+ my ($component,$arch,$package_source) = ($1,$2,$3);
+ $arch =~ s/binary-//;
+ next if exists $p_f{$component}{$arch} and
+ $p_f{$component}{$arch} =~ /\.xz$/;
+ $p_f{$component}{$arch} = File::Spec->catfile(dirname($file),$f);
+ }
+ }
+ return (\%dist_info,\%p_f);
+}
+
+=item read_packages
+
+ read_packages($dist_dir,$callback,$progress)
+
+=over
+
+=item dist_dir
+
+Path to dists directory
+
+=item callback
+
+Function which is called with key, value pairs of suite, arch, component,
+Package, Source, Version, and Maintainer information for each package in the
+Packages file.
+
+=item progress
+
+Optional Term::ProgressBar object to output progress while reading packages.
+
+=back
+
+
+=cut
+
+sub read_packages {
+ my ($dist_dir,$callback,$p) = @_;
+
+ my %s_p;
+ my $tot = 0;
+ for my $dist (make_list($dist_dir)) {
+ my $dist_dir_h = IO::Dir->new($dist);
+ my @dist_names =
+ grep { $_ !~ /^\./ and
+ -d $dist.'/'.$_ and
+ not -l $dist.'/'.$_
+ } $dist_dir_h->read or
+ die "Unable to read from dir: $!";
+ $dist_dir_h->close or
+ die "Unable to close dir: $!";
+ while (my $dist = shift @dist_names) {
+ my $dir = $dist_dir.'/'.$dist;
+ my ($dist_info,$package_files) =
+ read_release_file(File::Spec->catfile($dist_dir,
+ $dist,
+ 'Release'));
+ $s_p{$dist_info->{Codename}} = $package_files;
+ }
+ for my $suite (keys %s_p) {
+ for my $component (keys %{$s_p{$suite}}) {
+ $tot += scalar keys %{$s_p{$suite}{$component}};
+ }
+ }
+ }
+ $p->target($tot) if $p;
+ my $done_archs = 0;
+ # parse packages files
+ for my $suite (keys %s_p) {
+ my $pkgs = 0;
+ for my $component (keys %{$s_p{$suite}}) {
+ my @archs = keys %{$s_p{$suite}{$component}};
+ if (grep {$_ eq 'source'} @archs) {
+ @archs = ('source',grep {$_ ne 'source'} @archs);
+ }
+ for my $arch (@archs) {
+ my $pfh = open_compressed_file($s_p{$suite}{$component}{$arch}) or
+ die "Unable to open $s_p{$suite}{$component}{$arch} for reading: $!";
+ local $_;
+ local $/ = ''; # paragraph mode
+ while (<$pfh>) {
+ my %pkg;
+ for my $field (qw(Package Maintainer Version Source)) {
+ /^\Q$field\E: (.*)/m;
+ $pkg{$field} = $1;
+ }
+ next unless defined $pkg{Package} and
+ defined $pkg{Version};
+ $pkg{suite} = $suite;
+ $pkg{arch} = $arch;
+ $pkg{component} = $component;
+ $callback->(%pkg);
+ }
+ $p->update(++$done_archs) if $p;
+ }
+ }
+ }
+ $p->remove() if $p;
+}
+
+=back
+
+=cut
+
+1;
+
+__END__
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
my $cond = new Search::Estraier::Condition;
$cond->add_attr('@uri STRBW '.$bug_num.'/');
$cond->set_max(50);
- my $skip;
my $nres;
while ($nres = $est->search($cond,0) and $nres->doc_num > 0){
for my $rdoc (map {$nres->get_doc($_)} 0..($nres->doc_num-1)) {
}
+our $magic;
+
=over
=item retrieve_libravatar
}
require LWP::UserAgent;
- my $dest_type;
+ my $dest_type = 'png';
eval {
my $uri = libravatar_url(email => $param{email},
default => 404,
$ua->timeout(10);
# if the avatar is bigger than 30K, we don't want it either
$ua->max_size(30*1024);
+ $ua->default_header('Accept' => 'image/*');
my $r = $ua->get($uri);
if (not $r->is_success()) {
- die "Not successful in request";
+ if ($r->code != 404) {
+ die "Not successful in request";
+ }
+ # No avatar - cache a negative result
+ if ($config{libravatar_default_image} =~ m/\.(png|jpg)$/) {
+ $dest_type = $1;
+
+ system('cp', '-laf', $config{libravatar_default_image}, $cache_location.'.'.$dest_type) == 0
+ or die("Cannot copy $config{libravatar_default_image}");
+ # Returns from eval {}
+ return;
+ }
}
my $aborted = $r->header('Client-Aborted');
# if we exceeded max size, I'm not sure if we'll be
my $type = $r->header('Content-Type');
# if there's no content type, or it's not one we like, we won't
# bother going further
- die "No content type" if not defined $type;
- die "Wrong content type" if not $type =~ m{^image/([^/]+)$};
- $dest_type = $type_mapping{$1};
- die "No dest type" if not defined $dest_type;
+ if (defined $type) {
+ die "Wrong content type" if not $type =~ m{^image/([^/]+)$};
+ $dest_type = $type_mapping{$1};
+ die "No dest type" if not defined $dest_type;
+ }
# undo any content encoding
$r->decode() or die "Unable to decode content encoding";
# ok, now we need to convert it from whatever it is into a
eval {
print {$temp_fh} $r->content() or
die "Unable to print to temp file";
- close ($temp_fh);
+ close ($temp_fh) or
+ die "Unable to close temp file";
+ ### Figure out the actual type from the file
+ $magic = File::LibMagic->new() if not defined $magic;
+ $type = $magic->checktype_filename(abs_path($temp_fn));
+ die "Wrong content type ($type)" if not $type =~ m{^image/([^/;]+)(?:;|$)};
+ $dest_type = $type_mapping{$1};
+ die "No dest type for ($1)" if not defined $dest_type;
### resize all images to 80x80 and strip comments out of
### them. If convert has a bug, it would be possible for
### this to be an attack vector, but hopefully minimizing
croak("cache_location must be called with one of md5sum or email");
}
return (undef, 0) if blocked_libravatar($param{email},$md5sum);
- $stem = $config{libravatar_cache_dir}.'/'.$md5sum;
+ my $cache_dir = $param{cache_dir} // $config{libravatar_cache_dir};
+ $stem = $cache_dir.'/'.$md5sum;
for my $ext ('.png', '.jpg', '') {
my $path = $stem.$ext;
if (-e $path) {
-our $magic;
-
sub serve_cache_mod_perl {
my ($cache_location,$r,$timestamp) = @_;
if (not defined $cache_location or not length $cache_location) {
use Params::Validate qw(:types validate_with);
use Encode qw(encode encode_utf8 is_utf8);
use IO::InnerFile;
+use feature 'state';
=head1 NAME
$param{inner_file} = 0;
}
else {
- %param = validate_with(params => \@_,
- spec => {bug_num => {type => SCALAR,
- optional => 1,
- },
- logfh => {type => HANDLE,
- optional => 1,
- },
- log_name => {type => SCALAR,
- optional => 1,
- },
- inner_file => {type => BOOLEAN,
- default => 0,
- },
- }
- );
+ state $spec =
+ {bug_num => {type => SCALAR,
+ optional => 1,
+ },
+ logfh => {type => HANDLE,
+ optional => 1,
+ },
+ log_name => {type => SCALAR,
+ optional => 1,
+ },
+ inner_file => {type => BOOLEAN,
+ default => 0,
+ },
+ };
+ %param = validate_with(params => \@_,
+ spec => $spec,
+ );
}
- if (grep({exists $param{$_} and defined $param{$_}} qw(bug_num logfh log_name)) ne 1) {
- croak "Exactly one of bug_num, logfh, or log_name must be passed and must be defined";
+ if (grep({exists $param{$_} and defined $param{$_}}
+ qw(bug_num logfh log_name)) ne 1) {
+ croak "Exactly one of bug_num, logfh, or log_name ".
+ "must be passed and must be defined";
}
my $class = ref($this) || $this;
bless $self, $class;
if (exists $param{logfh}) {
- $self->{logfh} = $param{logfh}
- }
- elsif (exists $param{log_name}) {
- $self->{logfh} = IO::File->new($param{log_name},'r') or
- die "Unable to open bug log $param{log_name} for reading: $!";
- }
- elsif (exists $param{bug_num}) {
- my $location = getbuglocation($param{bug_num},'log');
- my $bug_log = getbugcomponent($param{bug_num},'log',$location);
- $self->{logfh} = IO::File->new($bug_log, 'r') or
- die "Unable to open bug log $bug_log for reading: $!";
+ $self->{logfh} = $param{logfh}
+ } else {
+ my $bug_log;
+ if (exists $param{bug_num}) {
+ my $location = getbuglocation($param{bug_num},'log');
+ $bug_log = getbugcomponent($param{bug_num},'log',$location);
+ } else {
+ $bug_log = $param{log_name};
+ }
+ if ($bug_log =~ m/\.gz$/) {
+ my $oldpath = $ENV{'PATH'};
+ $ENV{'PATH'} = '/bin:/usr/bin';
+ open($self->{logfh},'-|','gzip','-dc',$bug_log) or
+ die "Unable to open $bug_log for reading: $!";
+ $ENV{'PATH'} = $oldpath;
+ } else {
+ open($self->{logfh},'<',$bug_log) or
+ die "Unable to open $bug_log for reading: $!";
+ }
}
$self->{state} = 'kill-init';
} else {
my @result = $record->{text} =~ m/$regex/;
return @result;
- return $record->{text};
}
}
=cut
1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
--- /dev/null
+# This module 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 2017 by Don Armstrong <don@donarmstrong.com>.
+
+package Debbugs::Log::Spam;
+
+=head1 NAME
+
+Debbugs::Log::Spam -- an interface to debbugs .log.spam files
+
+=head1 SYNOPSIS
+
+use Debbugs::Log::Spam;
+
+my $spam = Debbugs::Log::Spam->new(bug_num => '12345');
+
+=head1 DESCRIPTION
+
+
+=head1 BUGS
+
+None known.
+
+=cut
+
+use warnings;
+use strict;
+use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
+use base qw(Exporter);
+
+BEGIN{
+ $VERSION = 1;
+ $DEBUG = 0 unless defined $DEBUG;
+
+ @EXPORT = ();
+ %EXPORT_TAGS = ();
+ @EXPORT_OK = ();
+ Exporter::export_ok_tags(keys %EXPORT_TAGS);
+ $EXPORT_TAGS{all} = [@EXPORT_OK];
+
+}
+
+use Carp;
+use feature 'state';
+use Params::Validate qw(:types validate_with);
+use Debbugs::Common qw(getbuglocation getbugcomponent filelock unfilelock);
+
+=head1 FUNCTIONS
+
+=over 4
+
+=item new
+
+Creates a new log spam reader.
+
+ my $spam_log = Debbugs::Log::Spam->new(log_spam_name => "56/123456.log.spam");
+ my $spam_log = Debbugs::Log::Spam->new(bug_num => $nnn);
+
+Parameters
+
+=over
+
+=item bug_num -- bug number
+
+=item log_spam_name -- name of log
+
+=back
+
+One of the above options must be passed.
+
+=cut
+
+sub new {
+ my $this = shift;
+ state $spec =
+ {bug_num => {type => SCALAR,
+ optional => 1,
+ },
+ log_spam_name => {type => SCALAR,
+ optional => 1,
+ },
+ };
+ my %param =
+ validate_with(params => \@_,
+ spec => $spec
+ );
+ if (grep({exists $param{$_} and
+ defined $param{$_}} qw(bug_num log_spam_name)) ne 1) {
+ croak "Exactly one of bug_num or log_spam_name".
+ "must be passed and must be defined";
+ }
+
+ my $class = ref($this) || $this;
+ my $self = {};
+ bless $self, $class;
+
+ if (exists $param{log_spam_name}) {
+ $self->{name} = $param{log_spam_name};
+ } elsif (exists $param{bug_num}) {
+ my $location = getbuglocation($param{bug_num},'log.spam');
+ my $bug_log = getbugcomponent($param{bug_num},'log.spam',$location);
+ $self->{name} = $bug_log;
+ }
+ $self->_init();
+ return $self;
+}
+
+
+sub _init {
+ my $self = shift;
+
+ $self->{spam} = {};
+ if (-e $self->{name}) {
+ open(my $fh,'<',$self->{name}) or
+ croak "Unable to open bug log spam '$self->{name}' for reading: $!";
+ binmode($fh,':encoding(UTF-8)');
+ while (<$fh>) {
+ chomp;
+ $self->{spam}{$_} = 1;
+ }
+ close ($fh);
+ }
+ return $self;
+}
+
+=item save
+
+$self->save();
+
+Saves changes to the bug log spam file.
+
+=cut
+
+sub save {
+ my $self = shift;
+ return unless keys %{$self->{spam}};
+ filelock($self->{name}.'.lock');
+ open(my $fh,'>',$self->{name}.'.tmp') or
+ croak "Unable to open bug log spam '$self->{name}.tmp' for writing: $!";
+ binmode($fh,':encoding(UTF-8)');
+ for my $msgid (keys %{$self->{spam}}) {
+ print {$fh} $msgid."\n";
+ }
+ close($fh) or croak "Unable to write to '$self->{name}.tmp': $!";
+ rename($self->{name}.'.tmp',$self->{name});
+ unfilelock();
+}
+
+=item is_spam
+
+ next if ($spam_log->is_spam('12456@exmaple.com'));
+
+Returns 1 if this message id confirms that the message is spam
+
+Returns 0 if this message is not spam
+
+=cut
+sub is_spam {
+ my ($self,$msgid) = @_;
+ return 0 if not defined $msgid or not length $msgid;
+ $msgid =~ s/^<|>$//;
+ if (exists $self->{spam}{$msgid} and
+ $self->{spam}{$msgid}
+ ) {
+ return 1;
+ }
+ return 0;
+}
+
+=item add_spam
+
+ $spam_log->add_spam('123456@example.com');
+
+Add a message id to the spam listing.
+
+You must call C<$self->save()> if you wish the changes to be written out to disk.
+
+=cut
+
+sub add_spam {
+ my ($self,$msgid) = @_;
+ $msgid =~ s/^<|>$//;
+ $self->{spam}{$msgid} = 1;
+}
+
+1;
+
+=back
+
+=cut
+
+__END__
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
use MIME::Parser;
use POSIX qw(strftime);
-use List::MoreUtils qw(apply);
+use List::AllUtils qw(apply);
# for convert_to_utf8
use Debbugs::UTF8 qw(convert_to_utf8);
use Debbugs::Config qw(:config);
use Params::Validate qw(:types validate_with);
use Encode qw(encode is_utf8);
-use Debbugs::UTF8 qw(encode_utf8_safely);
+use Debbugs::UTF8 qw(encode_utf8_safely convert_to_utf8);
use Debbugs::Packages;
message => {type => SCALAR,
},
envelope_from => {type => SCALAR,
- optional => 1,
+ default => $config{envelope_from},
},
recipients => {type => ARRAYREF|UNDEF,
optional => 1,
},
);
my @sendmail_arguments = @{$param{sendmail_arguments}};
- push @sendmail_arguments, '-f', $param{envelope_from} if exists $param{envelope_from};
+ push @sendmail_arguments, '-f', $param{envelope_from} if
+ exists $param{envelope_from} and
+ defined $param{envelope_from} and
+ length $param{envelope_from};
my @recipients;
@recipients = @{$param{recipients}} if defined $param{recipients} and
my $body = "On $date $who wrote:\n";
my $i = 60;
my $b_h;
+ # Default to UTF-8.
+ my $charset="utf-8";
## find the first part which has a defined body handle and appears
## to be text
if (defined $entity->bodyhandle) {
+ my $this_charset =
+ $entity->head->mime_attr("content-type.charset");
+ $charset = $this_charset if
+ defined $this_charset and
+ length $this_charset;
$b_h = $entity->bodyhandle;
} elsif ($entity->parts) {
my @parts = $entity->parts;
}
if (defined $part->bodyhandle and
$part->effective_type =~ /text/) {
+ my $this_charset =
+ $part->head->mime_attr("content-type.charset");
+ $charset = $this_charset if
+ defined $this_charset and
+ length $this_charset;
$b_h = $part->bodyhandle;
last;
}
while (defined($_ = $IO->getline)) {
$i--;
last if $i < 0;
- $body .= '> '. $_;
+ $body .= '> '. convert_to_utf8($_,$charset);
}
$IO->close();
};
use Params::Validate qw(validate_with :types);
use Debbugs::Common qw(make_list globify_scalar sort_versions);
-use List::Util qw(min max);
+use List::AllUtils qw(min max);
use IO::File;
our $_srcpkg;
sub getpkgsrc {
return $_pkgsrc if $_pkgsrc;
- return {} unless defined $Debbugs::Packages::gPackageSource;
+ return {} unless defined $config{package_source} and
+ length $config{package_source};
my %pkgsrc;
my %pkgcomponent;
my %srcpkg;
my $fh = IO::File->new($config{package_source},'r')
- or die("Unable to open $config{package_source} for reading: $!");
+ or croak("Unable to open $config{package_source} for reading: $!");
while(<$fh>) {
next unless m/^(\S+)\s+(\S+)\s+(\S.*\S)\s*$/;
my ($bin,$cmp,$src)=($1,$2,$3);
}
}
else {
- my $found_one_version = 0;
for my $version (@versions) {
next unless exists $bin->{$version};
if (exists $bin->{$version}{all}) {
arch => 'source',
versions => '0.1.1',
guess_source => 1,
- debug => \$debug,
warnings => \$warnings,
);
},
);
my ($warnings) = globify_scalar(exists $param{warnings}?$param{warnings}:undef);
- my ($debug) = globify_scalar(exists $param{debug} ?$param{debug} :undef);
my @packages = grep {defined $_ and length $_ } make_list($param{package});
my @archs = grep {defined $_ } make_list ($param{arch});
}
return;
}
- my ($p, $addmaint);
- my $anymaintfound=0; my $anymaintnotfound=0;
+ my ($addmaint);
my $ref = $param{data}{bug_num};
for my $p (splitpackages($param{data}{package})) {
$p = lc($p);
bug_num => $param{data}{bug_num},
type => 'bcc',
);
+ }
+ if (defined $config{cc_all_mails_to_addr} and
+ length $config{cc_all_mails_to_addr}
+ ) {
+ _add_address(recipients => $param{recipients},
+ address => $config{cc_all_mails_to},
+ reason => "cc_all_mails_to",
+ bug_num => $param{data}{bug_num},
+ type => 'bcc',
+ );
}
if (length $param{data}{owner}) {
my %seen_msg_ids;
my $current_msg=0;
- my $status = {};
my @messages;
while (my $record = $log->read_record()) {
$current_msg++;
use Encode qw(decode encode is_utf8);
use Storable qw(dclone);
-use List::Util qw(min max);
+use List::AllUtils qw(min max);
use Carp qw(croak);
$data{archived} = (defined($location) and ($location eq 'archive'))?1:0;
$data{bug_num} = $param{bug};
+ # mergedwith occasionally is sorted badly. Fix it to always be sorted by <=>
+ # and not include this bug
+ if (defined $data{mergedwith} and
+ $data{mergedwith}) {
+ $data{mergedwith} =
+ join(' ',
+ grep { $_ != $data{bug_num}}
+ sort { $a <=> $b }
+ split / /, $data{mergedwith}
+ );
+ }
return \%data;
}
my %split_fields =
(package => \&splitpackages,
affects => \&splitpackages,
+ # Ideally we won't have to split source, but because some consumers of
+ # get_bug_status cannot handle arrayref, we will split it here.
+ source => \&splitpackages,
blocks => $ditch_space_unique_and_sort,
blockedby => $ditch_space_unique_and_sort,
# this isn't strictly correct, but we'll split both of them for
=cut
sub lockreadbugmerge {
- my ($bug_num,$location) = @_;
my $data = lockreadbug(@_);
if (not defined $data) {
return (0,undef);
# are all merged with eachother
# We do a cmp sort instead of an <=> sort here, because that's
# what merge does
- my $expectmerge= join(' ',grep {$_ != $bug } sort @bugs);
+ my $expectmerge=
+ join(' ',grep {$_ != $bug }
+ sort { $a <=> $b }
+ @bugs);
if ($newdata->{mergedwith} ne $expectmerge) {
for (1..$locks) {
unfilelock(exists $param{locks}?$param{locks}:());
our %tt_templates;
our %filled_templates;
our $safe;
-our $hole = Safe::Hole->new({});
our $language;
# This function is what is called when someone does include('foo/bar')
# if there's an à (0xC3), it's probably something
# horrible, and we shouldn't try to convert it.
if (defined $call_back_data and $call_back_data !~ /\x{C3}/) {
- # this warning produces far too much useless output; elminating it
- # warn "failed to convert to utf8 (charset: $charset, data: $data), but succeeded with ISO8859-1: ".encode_utf8($call_back_data);
return $call_back_data;
}
}
- warn "failed to convert to utf8 (charset: $charset, data: $data)";
# Fallback to encode, which will probably also fail.
return __fallback_convert_to_utf8($data,$charset);
}
use Exporter qw(import);
use Debbugs::Config qw(:config);
-use List::Util qw(min);
+use List::AllUtils qw(min);
use Carp;
use IO::File;
install_data := install -m644 -p
PERL ?= /usr/bin/perl
+# Some tests need to run under an UTF-8 locale.
+UTF8_LOCALE ?= C.UTF-8
-all: build test
+all: build
build:
$(PERL) Makefile.PL
$(MAKE) -f Makefile.perl
test:
- $(PERL) -MTest::Harness -I. -e 'runtests(glob(q(t/*.t)))'
+ LC_ALL=$(UTF8_LOCALE) $(PERL) -MTest::Harness -I. -e 'runtests(glob(q(t/*.t)))'
test_%: t/%.t
- $(PERL) -MTest::Harness -I. -e 'runtests(q($<))'
+ LC_ALL=$(UTF8_LOCALE) $(PERL) -MTest::Harness -I. -e 'runtests(q($<))'
testcover:
- PERL5LIB=t/cover_lib/:. cover -test
+ LC_ALL=$(UTF8_LOCALE) PERL5LIB=t/cover_lib/:. cover -test
clean:
if [ -e Makefile.perl ]; then \
install: install_mostfiles
# install basic debbugs documentation
- $(install_data) COPYING UPGRADE README debian/README.mail $(doc_dir)
-
- # configure debbugs
- $(sbin_dir)/debbugsconfig
+ $(install_data) COPYING UPGRADE README.md debian/README.mail $(doc_dir)
+ $(MAKE) -f Makefile.perl install DESTDIR=$(DESTDIR)
install_mostfiles:
# create the directories if they aren't there
use ExtUtils::MakeMaker;
WriteMakefile(FIRST_MAKEFILE => 'Makefile.perl',
- PMLIBDIRS => ['Debbugs','Mail'],
- EXE_FILES => ['bin/local-debbugs',
- 'bin/add_bug_to_estraier',
- ],
- NAME => 'Debbugs',
- VERSION => '2.4.2',
- );
+ PMLIBDIRS => ['Debbugs','Mail'],
+ EXE_FILES => ['bin/local-debbugs',
+ 'bin/add_bug_to_estraier',
+ ],
+ NAME => 'Debbugs',
+ PREREQ_PM => {'AptPkg::Version' => 0,
+ 'CGI::Alert' => 0,
+ 'CGI::Simple' => 0,
+ 'Config::Simple' => 0,
+ 'Data::Dumper' => 0,
+ 'Digest::MD5' => 0,
+ 'ExtUtils::MakeMaker' => 0,
+ 'File::Basename' => 0,
+ 'File::Copy' => 0,
+ 'File::Find' => 0,
+ 'File::LibMagic' => 0,
+ 'File::Path' => 0,
+ 'File::stat' => 0,
+ 'File::Temp' => 0,
+ 'Getopt::Long' => 0,
+ 'HTML::Entities' => 0,
+ 'HTTP::Server::Simple' => 0,
+ 'HTTP::Status' => 0,
+ 'IO::File' => 0,
+ 'IO::Handle' => 0,
+ 'IO::InnerFile' => 0,
+ 'IO::Scalar' => 0,
+ 'IPC::Open2' => 0,
+ 'IPC::Open3' => 0,
+ 'IPC::Run' => 0,
+ 'Libravatar::URL' => 0,
+ 'List::AllUtils' => 0,
+ 'LWP::UserAgent' => 0,
+ 'Mail::Address' => 0,
+ 'Mail::CrossAssassin' => 0,
+ 'Mail::RFC822::Address' => 0,
+ 'Mail::SpamAssassin' => 0,
+ 'MIME::Decoder' => 0,
+ 'MIME::Parser' => 0,
+ 'MIME::Words' => 0,
+ 'MIME::Words::encode_mimewords' => 0,
+ 'Params::Validate' => 0,
+ 'Pod::Usage' => 0,
+ 'Safe::Hole' => 0,
+ 'Scalar::Util' => 0,
+ 'SOAP::Lite' => 0,
+ 'SOAP::Transport::HTTP' => 0,
+ 'Sys::Hostname' => 0,
+ 'Test::More' => 0,
+ 'Test::Pod' => 0,
+ 'Test::WWW::Mechanize' => 0,
+ 'Text::Iconv' => 0,
+ 'Text::Template' => 0,
+ 'threads::shared' => 0,
+ 'Time::HiRes' => 0,
+ 'URI::Escape' => 0,
+ },
+ VERSION => '2.4.2',
+ );
--- /dev/null
+#! /usr/bin/perl
+# debbugs-spamscan-log 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 2012 by Don Armstrong <don@donarmstrong.com>.
+
+
+use warnings;
+use strict;
+
+use Getopt::Long qw(:config no_ignore_case);
+use Pod::Usage;
+
+=head1 NAME
+
+debbugs-spamscan-log -- Scan log files for spam and populate nnn.log.spam
+
+=head1 SYNOPSIS
+
+debbugs-spamscan-log [options] bugnumber [[bugnumber2]..]
+
+ Options:
+ --spool-dir debbugs spool directory
+ --debug, -d debugging level (Default 0)
+ --help, -h display this help
+ --man, -m display manual
+
+=head1 OPTIONS
+
+=over
+
+=item B<--spool-dir>
+
+Debbugs spool directory; defaults to the value configured in the
+debbugs configuration file.
+
+=item B<--debug, -d>
+
+Debug verbosity.
+
+=item B<--help, -h>
+
+Display brief useage information.
+
+=item B<--man, -m>
+
+Display this manual.
+
+=back
+
+=head1 EXAMPLES
+
+Rebuild the index.db for db-h.
+
+ debbugs-spamscan-log;
+
+Rebuild the index.db for archive
+
+ debbugs-spamscan-log archive;
+
+
+=cut
+
+
+use vars qw($DEBUG);
+
+use Debbugs::Log qw(record_regex);
+use Debbugs::Log::Spam;
+use Debbugs::Config qw(:config);
+use IPC::Open3 qw(open3);
+
+my %options =
+ (debug => 0,
+ help => 0,
+ man => 0,
+ verbose => 0,
+ quiet => 0,
+ quick => 0,
+ spamc => 'spamc',
+ spamc_opts => [],
+ );
+
+
+GetOptions(\%options,
+ 'quick|q',
+ 'service|s',
+ 'sysconfdir|c',
+ 'spool_dir|spool-dir=s',
+ 'spamc=s',
+ 'spamc_opts|spamc-opts=s@',
+ 'debug|d+','help|h|?','man|m');
+
+pod2usage() if $options{help};
+pod2usage({verbose=>2}) if $options{man};
+
+$DEBUG = $options{debug};
+
+my @USAGE_ERRORS;
+$options{verbose} = $options{verbose} - $options{quiet};
+
+if (not @ARGV) {
+ push @USAGE_ERRORS,
+ "You must provide a bug number to examine\n";
+}
+
+pod2usage(join("\n",@USAGE_ERRORS)) if @USAGE_ERRORS;
+
+if (exists $options{spool_dir} and defined $options{spool_dir}) {
+ $config{spool_dir} = $options{spool_dir};
+}
+chdir($config{spool_dir}) or die "chdir $config{spool_dir} failed: $!";
+
+for my $bug_num (@ARGV) {
+ my $log = Debbugs::Log->new(bug_num => $bug_num) or
+ die "Unable to open bug log for $bug_num";
+ my $spam = Debbugs::Log::Spam->new(bug_num => $bug_num) or
+ die "Unable to open bug log spam for $bug_num";
+
+ my %seen_msgids;
+ while (my $record = $log->read_record()) {
+ next if $record->{type} eq 'html';
+ next if $record->{type} eq 'autocheck';
+ my ($msg_id) = record_regex($record,
+ qr/^Message-Id:\s+<(.+)>/mi);
+ next unless defined $msg_id;
+ if ($msg_id =~ /$config{email_domain}$/) {
+ print STDERR "skipping $msg_id\n" if $DEBUG;
+ next;
+ }
+ print STDERR "examining $msg_id: " if $DEBUG;
+ if ($seen_msgids{$msg_id}) {
+ print STDERR "already seen\n" if $DEBUG;
+ next;
+ }
+ $seen_msgids{$msg_id}=1;
+ if ($spam->is_spam($msg_id)) {
+ print STDERR "already spam\n" if $DEBUG;
+ next;
+ }
+ my $is_spam;
+ eval {
+ my ($spamc,$child_out);
+ my $old_sig = $SIG{"PIPE"};
+ $SIG{"PIPE"} = sub {
+ die "SIGPIPE in child for some reason";
+ };
+ my $childpid =
+ open3($spamc,$child_out,0,
+ $options{spamc},'-E',@{$options{spamc_opts}}) or
+ die "Unable to fork spamc: $!";
+ if (not $childpid) {
+ die "Unable to fork spamc";
+ }
+ print {$spamc} $record->{text};
+ close($spamc) or die "Unable to close spamc: $!";
+ waitpid($childpid,0);
+ if ($DEBUG) {
+ print STDERR "[$?;".($? >> 8)."] ";
+ print STDERR map {s/\n//; $_ } <$child_out>;
+ print STDERR " ";
+ }
+ close($child_out);
+ $SIG{"PIPE"} = $old_sig;
+ if ($? >> 8) {
+ $is_spam = 1;
+ }
+ };
+ if ($@) {
+ print STDERR "processing of $msg_id failed [$@]\n";
+ } else {
+ if ($is_spam) {
+ print STDERR "it's spam\n" if $DEBUG;
+ $spam->add_spam($msg_id);
+ }
+ else {
+ print STDERR "it's ham\n" if $DEBUG;
+ }
+ }
+ }
+ $spam->save();
+}
+
+
+__END__
+
+# Local Variables:
+# cperl-indent-level: 4
+# indent-tabs-mode: nil
+# End:
);
GetOptions(\%options,
- 'daemon|D','show|s','search|select|S','mirror|M', 'stop',
+ 'daemon|D','show|s','search|select|S','mirror|M', 'stop|exit|quit',
'detach!',
'css=s','cgi_bin|cgi-bin|cgi=s',
'verbose|v+','quiet|q+',
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";
+ push @USAGE_ERRORS,"You must pass one (and only one) of --daemon --show --search --mirror or --stop";
}
$options{verbose} = $options{verbose} - $options{quiet};
print STDERR "Unable to determine if daemon is running: $!\n";
exit 1;
}
+ my $conf = IO::File->new($options{mirror_location}.'/debbugs_config_local','w') or
+ die "Unable to open $options{mirror_location}/debbugs_config_local for writing: $!";
+ print {$conf} <<"EOF";
+\$gConfigDir = "$options{mirror_location}";
+\$gSpoolDir = "$options{mirror_location}";
+\$gWebHost = 'localhost:$options{port}';
+\$gPackageSource = '';
+\$gPseudoDescFile = '';
+\$gPseudoMaintFile = '';
+\$gMaintainerFile = '';
+\$gMaintainerFileOverride = '';
+\$config{source_maintainer_file} = '';
+\$config{source_maintainer_file_override} = '';
+\$gProject = 'Local Debbugs';
+1;
+EOF
+ close $conf;
+ $ENV{DEBBUGS_CONFIG_FILE} = $options{mirror_location}.'/debbugs_config_local';
# ok, now lets daemonize
# XXX make sure that all paths have been turned into absolute
package local_debbugs::server;
use IO::File;
use HTTP::Server::Simple;
- use base qw(HTTP::Server::Simple::CGI);
+ use base qw(HTTP::Server::Simple::CGI HTTP::Server::Simple::CGI::Environment);
sub net_server {
return 'Net::Server::Fork';
sub handle_request {
my ($self,$cgi) = @_;
+ $ENV{DEBBUGS_CONFIG_FILE} = $options{mirror_location}.'/debbugs_config_local';
my $base_uri = 'http://'.$cgi->virtual_host;
if ($cgi->virtual_port ne 80) {
$base_uri .= ':'.$cgi->virtual_port;
}
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";
- }
+ #print "HTTP/1.1 200 OK\n";
+ open(my $fh,'-|',"$options{cgi_bin}/$1") or
+ die "Unable to execute $options{cgi_bin}/$1";
+ my $status;
+ my $cache = '';
+ while (<$fh>) {
+ if (/Status: (\d+\s+.+?)\n?$/) {
+ $status = $1;
+ print "HTTP/1.1 $status\n";
+ print STDERR "'$status'\n";
+ last;
+ }
+ $cache .= $_;
+ if (/^$/) {
+ print "HTTP/1.1 200 OK\n";
+ last;
+ }
+ }
+ print $cache;
+ print <$fh>;
+ close($fh) or die "Unable to close";
+ }
elsif ($path =~ m{^/?css/bugs.css}) {
my $fh = IO::File->new($options{css},'r') or
die "Unable to open $options{css} for reading: $!";
);
my ($output,$error) = ('','');
my $h = IPC::Run::start(['rsync',@{$param{options}}],
- \undef,\$output,\$error);
+ \undef,$param{log},$param{log});
while ($h->pump) {
- print {$param{log}} $output,$error;
#print {$param{debug}} $error if defined $param{debug};
}
$h->finish();
+++ /dev/null
-*.out
-*.trace
# for read_log_records
use Debbugs::Log qw(:read);
-use Debbugs::CGI qw(:url :html :util :cache);
+use Debbugs::Log::Spam;
+use Debbugs::CGI qw(:url :html :util :cache :usertags);
use Debbugs::CGI::Bugreport qw(:all);
use Debbugs::Common qw(buglog getmaintainers make_list bug_status);
use Debbugs::Packages qw(getpkgsrc);
use Debbugs::Status qw(splitpackages split_status_fields get_bug_status isstrongseverity);
-use Debbugs::User;
-
use Scalar::Util qw(looks_like_number);
use Debbugs::Text qw(:templates);
-use List::Util qw(max);
+use List::AllUtils qw(max);
use CGI::Simple;
);
# This is craptacular.
-my $ref = $param{bug} or quitcgi("No bug number");
-$ref =~ /(\d+)/ or quitcgi("Invalid bug number");
+my $ref = $param{bug} or quitcgi("No bug number", '400 Bad Request');
+$ref =~ /(\d+)/ or quitcgi("Invalid bug number", '400 Bad Request');
$ref = $1;
my $short = "#$ref";
my ($msg) = $param{msg} =~ /^(\d+)$/ if exists $param{msg};
## Identify the users required
for my $user (map {split /[\s*,\s*]+/} make_list($param{users}||[])) {
next unless length($user);
- push @dependent_files,Debbugs::User::usertag_flie_from_email($user);
+ push @dependent_files,Debbugs::User::usertag_file_from_email($user);
}
if (defined $param{usertag}) {
for my $usertag (make_list($param{usertag})) {
my ($user, $tag) = split /:/, $usertag, 2;
- push @dependent_files,Debbugs::User::usertag_flie_from_email($user);
+ push @dependent_files,Debbugs::User::usertag_file_from_email($user);
}
}
$etag =
],
);
if (not $etag) {
- print $q->header(-status => 304);
+ print $q->header(-status => 304,
+ -cache_control => 'public, max-age=600',
+ -etag => $etag,
+ -charset => 'utf-8',
+ -content_type => 'text/html',
+ );
print "304: Not modified\n";
exit 0;
}
print $q->header(-status => 200,
-cache_control => 'public, max-age=600',
-etag => $etag,
+ -charset => 'utf-8',
-content_type => 'text/html',
);
exit 0;
}
}
-
-my $buglogfh;
-if ($buglog =~ m/\.gz$/) {
- my $oldpath = $ENV{'PATH'};
- $ENV{'PATH'} = '/bin:/usr/bin';
- $buglogfh = IO::File->new("zcat $buglog |") or quitcgi("open log for $ref: $!");
- $ENV{'PATH'} = $oldpath;
-} else {
- $buglogfh = IO::File->new($buglog,'r') or quitcgi("open log for $ref: $!");
-}
-
-
my %status;
if ($need_status) {
%status = %{split_status_fields(get_bug_status(bug=>$ref,
}
my @records;
+my $spam;
eval{
- @records = read_log_records(logfh => $buglogfh,inner_file => 1);
+ @records = read_log_records(bug_num => $ref,inner_file => 1);
+ $spam = Debbugs::Log::Spam->new(bug_num => $ref);
};
if ($@) {
quitcgi("Bad bug log for $gBug $ref. Unable to read records: $@");
}
-undef $buglogfh;
-
my $log='';
my $msg_num = 0;
$record_wanted_anyway = 1 if record_regex($record,qr/^Received: \(at control\)/);
next if not $boring and not $record->{type} eq $wanted_type and not $record_wanted_anyway and @records > 1;
$seen_message_ids{$msg_id} = 1 if defined $msg_id;
+ # skip spam messages if we're outputting more than one message
+ next if @records > 1 and $spam->is_spam($msg_id);
my @lines;
if ($record->{inner_file}) {
push @lines, $record->{fh}->getline;
\%seen_msg_ids,
trim_headers => $trim_headers,
avatars => $avatars,
+ terse => $terse,
+ # if we're only looking at one record, allow
+ # spam to be output
+ spam => (@records > 1)?$spam:undef,
);
}
}
if (@blockedby && $status{"pending"} ne 'fixed' && ! length($status{done})) {
for my $b (@blockedby) {
my %s = %{get_bug_status($b)};
- next if $s{"pending"} eq 'fixed' || length $s{done};
+ next if (defined $s{pending} and
+ $s{"pending"} eq 'fixed') or
+ length $s{done};
push @{$status{blockedby_array}},{bug_num => $b, subject => $s{subject}, status => \%s};
}
}
'&maybelink' => \&Debbugs::CGI::maybelink,
},
);
+
+__END__
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+++ /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 -w
-
-use DB_File;
-use Fcntl qw/O_RDONLY/;
-use Mail::Address;
-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";
-
-use Debbugs::Packages qw(:versions :mapping);
-use Debbugs::Versions;
-use Debbugs::MIME qw(decode_rfc1522);
-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;
-
-my %common_bugusertags;
-my $common_mindays = 0;
-my $common_maxdays = -1;
-my $common_archive = 0;
-my $common_repeatmerged = 1;
-my %common_include = ();
-my %common_exclude = ();
-my $common_raw_sort = 0;
-my $common_bug_reverse = 0;
-
-my $common_leet_urls = 0;
-
-my %common_reverse = (
- 'pending' => 0,
- 'severity' => 0,
-);
-my %common = (
- 'show_list_header' => 1,
- 'show_list_footer' => 1,
-);
-
-sub exact_field_match {
- my ($field, $values, $status) = @_;
- my @values = @$values;
- my @ret = grep {$_ eq $status->{$field} } @values;
- $#ret != -1;
-}
-sub contains_field_match {
- my ($field, $values, $status) = @_;
- foreach my $data (@$values) {
- return 1 if (index($status->{$field}, $data) > -1);
- }
- return 0;
-}
-
-sub detect_user_agent {
- my $userAgent = $ENV{HTTP_USER_AGENT};
- return { 'name' => 'unknown' } unless defined $userAgent;
- return { 'name' => 'links' } if ( $userAgent =~ m,^ELinks,);
- return { 'name' => 'lynx' } if ( $userAgent =~ m,^Lynx,);
- return { 'name' => 'wget' } if ( $userAgent =~ m,^Wget,);
- return { 'name' => 'gecko' } if ( $userAgent =~ m,^Mozilla.* Gecko/,);
- return { 'name' => 'ie' } if ( $userAgent =~ m,^.*MSIE.*,);
- return { 'name' => 'unknown' };
-}
-
-my %field_match = (
- 'subject' => \&contains_field_match,
- 'tags' => sub {
- my ($field, $values, $status) = @_;
- my %values = map {$_=>1} @$values;
- foreach my $t (split /\s+/, $status->{$field}) {
- return 1 if (defined $values{$t});
- }
- return 0;
- },
- 'severity' => \&exact_field_match,
- 'pending' => \&exact_field_match,
- 'originator' => \%contains_field_match,
- 'forwarded' => \%contains_field_match,
- 'owner' => \%contains_field_match,
-);
-my @common_grouping = ( 'severity', 'pending' );
-my %common_grouping_order = (
- 'pending' => [ qw( pending forwarded pending-fixed fixed done absent ) ],
- 'severity' => \@gSeverityList,
-);
-my %common_grouping_display = (
- 'pending' => 'Status',
- 'severity' => 'Severity',
-);
-my %common_headers = (
- 'pending' => {
- "pending" => "outstanding",
- "pending-fixed" => "pending upload",
- "fixed" => "fixed in NMU",
- "done" => "resolved",
- "forwarded" => "forwarded to upstream software authors",
- "absent" => "not applicable to this version",
- },
- 'severity' => \%gSeverityDisplay,
-);
-
-my $common_version;
-my $common_dist;
-my $common_arch;
-
-my $debug = 0;
-my $use_bug_idx = 0;
-my %bugidx;
-
-sub array_option($) {
- my ($val) = @_;
- my @vals;
- @vals = ( $val ) if (ref($val) eq "" && $val );
- @vals = ( $$val ) if (ref($val) eq "SCALAR" && $$val );
- @vals = @{$val} if (ref($val) eq "ARRAY" );
- return @vals;
-}
-
-sub filter_include_exclude($\%) {
- my ($val, $filter_map) = @_;
- my @vals = array_option($val);
- my @data = map {
- if (/^([^:]*):(.*)$/) { if ($1 eq 'subj') { ['subject', $2]; } else { [$1, $2] } } else { ['tags', $_] }
- } split /[\s,]+/, join ',', @vals;
- foreach my $data (@data) {
- &quitcgi("Invalid filter key: '$data->[0]'") if (!exists($field_match{$data->[0]}));
- push @{$filter_map->{$data->[0]}}, $data->[1];
- }
-}
-
-sub filter_option($$\%) {
- my ($key, $val, $filter_map) = @_;
- my @vals = array_option($val);
- foreach $val (@vals) {
- push @{$filter_map->{$key}}, $val;
- }
-}
-
-sub set_option {
- my ($opt, $val) = @_;
- if ($opt eq "use-bug-idx") {
- $use_bug_idx = $val;
- if ( $val ) {
- $common_headers{pending}{open} = $common_headers{pending}{pending};
- 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;
- }
- }
- if ($opt =~ m/^show_list_(foot|head)er$/) { $common{$opt} = $val; }
- if ($opt eq "archive") { $common_archive = $val; }
- if ($opt eq "repeatmerged") { $common_repeatmerged = $val; }
- if ($opt eq "exclude") {
- filter_include_exclude($val, %common_exclude);
- }
- if ($opt eq "include") {
- filter_include_exclude($val, %common_include);
- }
- if ($opt eq "raw") { $common_raw_sort = $val; }
- if ($opt eq "bug-rev") { $common_bug_reverse = $val; }
- if ($opt eq "pend-rev") { $common_reverse{pending} = $val; }
- if ($opt eq "sev-rev") { $common_reverse{severity} = $val; }
- if ($opt eq "pend-exc") {
- filter_option('pending', $val, %common_exclude);
- }
- if ($opt eq "pend-inc") {
- filter_option('pending', $val, %common_include);
- }
- if ($opt eq "sev-exc") {
- filter_option('severity', $val, %common_exclude);
- }
- if ($opt eq "sev-inc") {
- filter_option('severity', $val, %common_include);
- }
- if ($opt eq "version") { $common_version = $val; }
- if ($opt eq "dist") { $common_dist = $val; }
- if ($opt eq "arch") { $common_arch = $val; }
- if ($opt eq "maxdays") { $common_maxdays = $val; }
- if ($opt eq "mindays") { $common_mindays = $val; }
- if ($opt eq "bugusertags") { %common_bugusertags = %{$val}; }
-}
-
-sub readparse {
- my ($key, $val, %ret);
- my $in = "";
- if ($#ARGV >= 0) {
- $in .= ";" . join("&", map { s/&/%26/g; s/;/%3b/g; $_ } @ARGV);
- }
- if (defined $ENV{"QUERY_STRING"} && $ENV{"QUERY_STRING"} ne "") {
- $in .= ";" . $ENV{QUERY_STRING};
- }
- if (defined $ENV{"REQUEST_METHOD"} && $ENV{"REQUEST_METHOD"} eq "POST"
- && defined $ENV{"CONTENT_TYPE"}
- && $ENV{"CONTENT_TYPE"} eq "application/x-www-form-urlencoded")
- {
- my $inx;
- read(STDIN,$inx,$ENV{CONTENT_LENGTH});
- $in .= ";" . $inx;
- }
- return unless ($in ne "");
-
- if (defined $ENV{"HTTP_COOKIE"}) {
- my $x = $ENV{"HTTP_COOKIE"};
- $x =~ s/;\s+/;/g;
- $in = "$x;$in";
- }
- $in =~ s/&/;/g;
- $in =~ s/;;+/;/g; $in =~ s/^;//; $in =~ s/;$//;
- foreach (split(/[&;]/,$in)) {
- s/\+/ /g;
- ($key, $val) = split(/=/,$_,2);
- $key=~s/%(..)/pack("c",hex($1))/ge;
- $val=~s/%(..)/pack("c",hex($1))/ge;
- if ( exists $ret{$key} ) {
- if ( !exists $ret{"&$key"} ) {
- $ret{"&$key"} = [ $ret{$key} ];
- }
- push @{$ret{"&$key"}},$val;
- }
- $ret{$key}=$val;
- }
-
-$debug = 1 if (defined $ret{"debug"} && $ret{"debug"} eq "aj");
-
- $common_leet_urls = 1
- if (defined $ret{"leeturls"} && $ret{"leeturls"} eq "yes");
-
- return %ret;
-}
-
-# 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 {
- return htmlize_packagelinks(@_);
-}
-
-# Generate a comma-separated list of HTML links to each address given in
-# $addresses, which should be a comma-separated list of RFC822 addresses.
-# $urlfunc should be a reference to a function like mainturl or submitterurl
-# which returns the URL for each individual address.
-sub htmladdresslinks {
- htmlize_addresslinks(@_);
-}
-
-# Generate a comma-separated list of HTML links to each maintainer given in
-# $maints, which should be a comma-separated list of RFC822 addresses.
-sub htmlmaintlinks {
- my ($prefixfunc, $maints) = @_;
- return htmladdresslinks($prefixfunc, \&mainturl, $maints);
-}
-
-sub htmlindexentry {
- my $ref = shift;
- my %status = %{getbugstatus($ref)};
- return htmlindexentrystatus(%status) if (%status);
- return "";
-}
-
-sub htmlindexentrystatus {
- my $s = shift;
- my %status = %{$s};
-
- my $result = "";
-
- if ($status{severity} eq 'normal') {
- $showseverity = '';
- } elsif (isstrongseverity($status{severity})) {
- $showseverity = "<strong>Severity: $status{severity}</strong>;\n";
- } else {
- $showseverity = "Severity: <em>$status{severity}</em>;\n";
- }
-
- $result .= htmlpackagelinks($status{"package"}, 1);
-
- my $showversions = '';
- if (@{$status{found_versions}}) {
- my @found = @{$status{found_versions}};
- local $_;
- s{/}{ } foreach @found;
- $showversions .= join ', ', map htmlsanit($_), @found;
- }
- if (@{$status{fixed_versions}}) {
- $showversions .= '; ' if length $showversions;
- $showversions .= '<strong>fixed</strong>: ';
- my @fixed = @{$status{fixed_versions}};
- local $_;
- s{/}{ } foreach @fixed;
- $showversions .= join ', ', map htmlsanit($_), @fixed;
- }
- $result .= " ($showversions)" if length $showversions;
- $result .= ";\n";
-
- $result .= $showseverity;
- $result .= htmladdresslinks("Reported by: ", \&submitterurl,
- $status{originator});
- $result .= ";\nOwned by: " . htmlsanit($status{owner})
- if length $status{owner};
- $result .= ";\nTags: <strong>"
- . htmlsanit(join(", ", sort(split(/\s+/, $status{tags}))))
- . "</strong>"
- if (length($status{tags}));
- my @merged= split(/ /,$status{mergedwith});
- my $mseparator= ";\nmerged with ";
- for my $m (@merged) {
- $result .= $mseparator."<A href=\"" . bugurl($m) . "\">#$m</A>";
- $mseparator= ", ";
- }
-
- if (length($status{done})) {
- $result .= ";\n<strong>Done:</strong> " . htmlsanit($status{done});
- $days = ceil($gRemoveAge - -M buglog($status{id}));
- if ($days >= 0) {
- $result .= ";\n<strong>Will be archived:</strong>" . ( $days == 0 ? " today" : $days == 1 ? " in $days day" : " in $days days" );
- } else {
- $result .= ";\n<strong>Archived</strong>";
- }
- }
-
- unless (length($status{done})) {
- if (length($status{forwarded})) {
- $result .= ";\n<strong>Forwarded</strong> to "
- . maybelink($status{forwarded});
- }
- my $daysold = int((time - $status{date}) / 86400); # seconds to days
- if ($daysold >= 7) {
- my $font = "";
- my $efont = "";
- $font = "em" if ($daysold > 30);
- $font = "strong" if ($daysold > 60);
- $efont = "</$font>" if ($font);
- $font = "<$font>" if ($font);
-
- my $yearsold = int($daysold / 365);
- $daysold -= $yearsold * 365;
-
- $result .= ";\n $font";
- my @age;
- push @age, "1 year" if ($yearsold == 1);
- push @age, "$yearsold years" if ($yearsold > 1);
- push @age, "1 day" if ($daysold == 1);
- push @age, "$daysold days" if ($daysold > 1);
- $result .= join(" and ", @age);
- $result .= " old$efont";
- }
- }
-
- $result .= ".";
-
- return $result;
-}
-
-sub urlargs {
- my $args = '';
- $args .= ";archive=yes" if $common_archive;
- $args .= ";repeatmerged=no" unless $common_repeatmerged;
- $args .= ";mindays=${common_mindays}" unless $common_mindays == 0;
- $args .= ";maxdays=${common_maxdays}" unless $common_maxdays == -1;
- $args .= ";version=$common_version" if defined $common_version;
- $args .= ";dist=$common_dist" if defined $common_dist;
- $args .= ";arch=$common_arch" if defined $common_arch;
- return $args;
-}
-
-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;
- my $code = shift;
- if ($common_leet_urls) {
- $code = "package" if ($code eq "pkg");
- $code = "source" if ($code eq "src");
- return urlsanit("/x/$code/$ref");
- } else {
- my $addurlargs = shift || 1;
- my $params = "$code=$ref";
- $params .= urlargs() if $addurlargs;
- return urlsanit("pkgreport.cgi" . "?" . $params);
- }
-}
-
-sub urlsanit {
- my $url = shift;
- $url =~ s/%/%25/g;
- $url =~ s/#/%23/g;
- $url =~ s/\+/%2b/g;
- my %saniarray = ('<','lt', '>','gt', '&','amp', '"','quot');
- $url =~ s/([<>&"])/\&$saniarray{$1};/g;
- return $url;
-}
-
-sub htmlsanit {
- my %saniarray = ('<','lt', '>','gt', '&','amp', '"','quot');
- my $in = shift || "";
- $in =~ s/([<>&"])/\&$saniarray{$1};/g;
- return $in;
-}
-
-sub bugurl {
- my $ref = shift;
- my $params = "bug=$ref";
- my $filename = '';
-
- if ($common_leet_urls) {
- my $msg = "";
- my $mbox = "";
- my $att = "";
- foreach my $val (@_) {
- $mbox = "/mbox" if ($val eq "mbox");
- $msg = "/$1" if ($val =~ /^msg=([0-9]+)/);
- $att = "/$1" if ($val =~ /^att=([0-9]+)/);
- $filename = "/$1" if ($val =~ /^filename=(.*)$/);
- }
- my $ext = "";
- if ($mbox ne "") {
- $ext = $mbox;
- } elsif ($att ne "") {
- $ext = "$att$filename";
- }
- return urlsanit("/x/$ref$msg$ext");
- } else {
- foreach my $val (@_) {
- $params .= ";mbox=yes" if ($val eq "mbox");
- $params .= ";msg=$1" if ($val =~ /^msg=([0-9]+)/);
- $params .= ";att=$1" if ($val =~ /^att=([0-9]+)/);
- $filename = $1 if ($val =~ /^filename=(.*)$/);
- $params .= ";archive=yes" if (!$common_archive && $val =~ /^archive.*$/);
- }
- $params .= ";archive=yes" if ($common_archive);
- $params .= ";repeatmerged=no" unless ($common_repeatmerged);
-
- my $pathinfo = '';
- $pathinfo = '/'.uri_escape($filename) if $filename ne '';
-
- return urlsanit("bugreport.cgi" . $pathinfo . "?" . $params);
- }
-}
-
-sub dlurl { bugurl(@_); }
-sub mboxurl { return bugurl($ref, "mbox"); }
-
-sub allbugs {
- return @{getbugs(sub { 1 })};
-}
-
-sub bugmatches {
- my ($hash, $status) = @_;
- foreach my $key( keys( %$hash ) ) {
- my $value = $hash->{$key};
- my $sub = $field_match{$key};
- return 1 if ($sub->($key, $value, $status));
- }
- return 0;
-}
-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));
- }
- my @merged = sort {$a<=>$b} $bug, split(/ /, $status{mergedwith});
- my $daysold = int((time - $status{date}) / 86400); # seconds to days
- return 1 unless ($common_mindays <= $daysold);
- return 1 unless ($common_maxdays == -1 || $daysold <= $common_maxdays);
- return 1 unless ($common_repeatmerged || !$seenmerged{$merged[0]});
- $seenmerged{$merged[0]} = 1;
- return 0;
-}
-
-sub htmlizebugs {
- $b = $_[0];
- my @bugs = @$b;
- my $anydone = 0;
-
- my @status = ();
- my %count;
- my $header = '';
- my $footer = '';
-
- if (@bugs == 0) {
- return "<HR><H2>No reports found!</H2></HR>\n";
- }
-
- if ( $common_bug_reverse ) {
- @bugs = sort {$b<=>$a} @bugs;
- } else {
- @bugs = sort {$a<=>$b} @bugs;
- }
- my %seenmerged;
- foreach my $bug (@bugs) {
- my %status = %{getbugstatus($bug)};
- next unless %status;
- next if bugfilter($bug, %status);
-
- my $html = sprintf "<li><a href=\"%s\">#%d: %s</a>\n<br>",
- bugurl($bug), $bug, htmlsanit($status{subject});
- $html .= htmlindexentrystatus(\%status) . "\n";
- my $key = join( '_', map( {$status{$_}} @common_grouping ) );
- $section{$key} .= $html;
- $count{"_$key"}++;
- foreach my $grouping ( @common_grouping ) {
- $count{"${grouping}_$status{$grouping}"}++;
- }
- $anydone = 1 if $status{pending} eq 'done';
- push @status, [ $bug, \%status, $html ];
- }
-
- my $result = "";
- if ($common_raw_sort) {
- $result .= "<UL>\n" . join("", map( { $_->[ 2 ] } @status ) ) . "</UL>\n";
- } else {
- my (@order, @headers);
- for( my $i = 0; $i < @common_grouping; $i++ ) {
- my $grouping_name = $common_grouping[ $i ];
- my @items = @{ $common_grouping_order{ $grouping_name } };
- @items = reverse( @items ) if ( $common_reverse{ $grouping_name } );
- my @neworder = ();
- my @newheaders = ();
- if ( @order ) {
- foreach my $grouping ( @items ) {
- push @neworder, map( { "${_}_$grouping" } @order );
- push @newheaders, map( { "$_ - $common_headers{$grouping_name}{$grouping}" } @headers );
- }
- @order = @neworder;
- @headers = @newheaders;
- } else {
- push @order, @items;
- push @headers, map( { $common_headers{$common_grouping[$i]}{$_} } @items );
- }
- }
- $header .= "<ul>\n";
- for ( my $i = 0; $i < @order; $i++ ) {
- my $order = $order[ $i ];
- next unless defined $section{$order};
- my $count = $count{"_$order"};
- my $bugs = $count == 1 ? "bug" : "bugs";
- $header .= "<li><a href=\"#$order\">$headers[$i]</a> ($count $bugs)</li>\n";
- }
- $header .= "</ul>\n";
- for ( my $i = 0; $i < @order; $i++ ) {
- my $order = $order[ $i ];
- next unless defined $section{$order};
- if ($common{show_list_header}) {
- my $count = $count{"_$order"};
- my $bugs = $count == 1 ? "bug" : "bugs";
- $result .= "<HR><H2><a name=\"$order\"></a>$headers[$i] ($count $bugs)</H2>\n";
- } else {
- $result .= "<HR><H2>$headers[$i]</H2>\n";
- }
- $result .= "<UL>\n";
- $result .= $section{$order};
- $result .= "</UL>\n";
- }
- $footer .= "<ul>\n";
- foreach my $grouping ( @common_grouping ) {
- my $local_result = '';
- foreach my $key ( @{$common_grouping_order{ $grouping }} ) {
- my $count = $count{"${grouping}_$key"};
- next if !$count;
- $local_result .= "<li>$count $common_headers{$grouping}{$key}</li>\n";
- }
- if ( $local_result ) {
- $footer .= "<li>$common_grouping_display{$grouping}<ul>\n$local_result</ul></li>\n";
- }
- }
- $footer .= "</ul>\n";
- }
-
- $result = $header . $result if ( $common{show_list_header} );
- $result .= $gHTMLExpireNote if $gRemoveAge and $anydone;
- $result .= "<hr>" . $footer if ( $common{show_list_footer} );
- return $result;
-}
-
-sub countbugs {
- return count_bugs(function=>shift,
- archive => $commonarchive,
- );
-}
-
-sub getbugs {
- my $bugfunc = shift;
- my $opt = shift;
-
- my @result = ();
-
- my $fastidx;
- if (!defined $opt) {
- # leave $fastidx undefined;
- } elsif (!$common_archive) {
- $fastidx = "$gSpoolDir/by-$opt.idx";
- } else {
- $fastidx = "$gSpoolDir/by-$opt-arc.idx";
- }
-
- if (defined $fastidx && -e $fastidx) {
- my %lookup;
-print STDERR "optimized\n" if ($debug);
- 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, keys %{$bugs};
- }
- }
- untie %lookup;
-print STDERR "done optimized\n" if ($debug);
- } else {
- if ( $common_archive ) {
- open I, "<$gSpoolDir/index.archive"
- or &quitcgi("$gSpoolDir/index.archive: $!");
- } else {
- open I, "<$gSpoolDir/index.db"
- or &quitcgi("$gSpoolDir/index.db: $!");
- }
- while(<I>) {
- if (m/^(\S+)\s+(\d+)\s+(\d+)\s+(\S+)\s+\[\s*([^]]*)\s*\]\s+(\w+)\s+(.*)$/) {
- if ($bugfunc->(pkg => $1, bug => $2, status => $4,
- submitter => $5, severity => $6, tags => $7))
- {
- push (@result, $2);
- }
- }
- }
- close I;
- }
- @result = sort {$a <=> $b} @result;
- return \@result;
-}
-
-sub emailfromrfc822 {
- my $email = shift;
- $email =~ s/\s*\(.*\)\s*//;
- $email = $1 if ($email =~ m/<(.*)>/);
- return $email;
-}
-
-sub maintencoded {
- my $input = shift;
- my $encoded = '';
-
- while ($input =~ m/\W/) {
- $encoded.=$`.sprintf("-%02x_",unpack("C",$&));
- $input= $';
- }
-
- $encoded.= $input;
- $encoded =~ s/-2e_/\./g;
- $encoded =~ s/^([^,]+)-20_-3c_(.*)-40_(.*)-3e_/$1,$2,$3,/;
- $encoded =~ s/^(.*)-40_(.*)-20_-28_([^,]+)-29_$/,$1,$2,$3/;
- $encoded =~ s/-20_/_/g;
- $encoded =~ s/-([^_]+)_-/-$1/g;
- return $encoded;
-}
-
-
-sub getbugstatus {
- 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 {
- my $pkg = shift;
-
- if (defined $common_version) {
- return "version $common_version";
- } elsif (defined $common_dist) {
- my @distvers = getversions($pkg, $common_dist, $common_arch);
- @distvers = sort @distvers;
- local $" = ', ';
- if (@distvers > 1) {
- return "versions @distvers";
- } elsif (@distvers == 1) {
- return "version @distvers";
- }
- }
-
- return undef;
-}
-
-1;
+++ /dev/null
-#!/usr/bin/perl -w
-
-use strict;
-use POSIX qw(strftime);
-require './common.pl';
-
-my $oldcookies = $ENV{"HTTP_COOKIE"};
-$ENV{"HTTP_COOKIE"} = "";
-my %param = readparse();
-
-my %oldcookies = map { ($1, $2) if (m/(.*)=(.*)/) } split /[;&]/, $oldcookies;
-
-my $clear = (defined $param{"clear"} && $param{"clear"} eq "yes");
-my @time_now = gmtime(time());
-my $time_future = strftime("%a, %d-%b-%Y %T GMT",
- 59, 59, 23, 31, 11, $time_now[5]+10);
-my $time_past = strftime("%a, %d-%b-%Y %T GMT",
- 59, 59, 23, 31, 11, $time_now[5]-10);
-
-my @cookie_options = qw(repeatmerged terse reverse trim oldview);
-
-print "Content-Type: text/html; charset=utf-8\n";
-
-for my $c (@cookie_options) {
- if (defined $param{$c}) {
- printf "Set-Cookie: %s=%s; expires=%s; domain=%s; path=/\n",
- $c, $param{$c}, $time_future, "bugs.debian.org";
- } elsif ($clear) {
- printf "Set-Cookie: %s=%s; expires=%s; domain=%s; path=/\n",
- $c, "", $time_past, "bugs.debian.org";
- }
-}
-print "\n";
-print "<p>Oldcookies $oldcookies .\n";
-print "<p>Cookies set!\n";
-for my $c (@cookie_options) {
- my $old = $oldcookies{$c} || "unset";
- if (defined $param{$c}) {
- printf "<br>Set %s=%s (was %s)\n", $c, $param{$c}, $old;
- } elsif ($clear) {
- printf "<br>Cleared %s (was %s)\n", $c, $old;
- } else {
- printf "<br>Didn't touch %s (was %s; use clear=yes to clear)\n", $c, $old;
- }
-}
my $indexon = $param{indexon};
if ($param{indexon} !~ m/^(pkg|src|maint|submitter|tag)$/) {
- quitcgi("You have to choose something to index on");
+ quitcgi("You have to choose something to index on", '400 Bad Request');
}
my $repeatmerged = $param{repeatmerged} eq 'yes';
my $archive = $param{archive} eq "yes";
my $sortby = $param{sortby};
if ($sortby !~ m/^(alpha|count)$/) {
- quitcgi("Don't know how to sort like that");
+ quitcgi("Don't know how to sort like that", '400 Bad Request');
}
my $Archived = $archive ? " Archived" : "";
binmode(STDOUT,':encoding(UTF-8)');
use POSIX qw(strftime nice);
+use List::AllUtils qw(uniq);
use Debbugs::Config qw(:globals :text :config);
"ord" => [2,3,4,1,0,5],
} ],
"oldview" => [ qw(status severity) ],
- "normal" => [ qw(status severity classification) ],
+ "normal" => [ qw(status severity classification) ],
+ raw => [{nam => 'Raw',def => 'Raw'}],
);
if (exists $param{which} and exists $param{data}) {
}
}
-quitcgi("You have to choose something to select by") unless grep {exists $param{$_}} keys %package_search_keys;
+quitcgi("You have to choose something to select by", '400 Bad Request')
+ unless grep {exists $param{$_}} keys %package_search_keys;
my $Archived = $param{archive} ? " Archived" : "";
print qq(<h2 class="outstanding"><!--<a class="options" href="javascript:toggle(1)">-->Options<!--</a>--></h2>\n);
+$param{orderings} =
+ [uniq((grep {!$hidden{$_}} keys %cats),
+ $param{ordering})];
print option_form(template => 'cgi/pkgreport_options',
param => \%param,
form_options => $form_options,
+++ /dev/null
-#!/usr/bin/perl -wT
-
-package debbugs;
-
-use strict;
-
-#require '/usr/lib/debbugs/errorlib';
-require './common.pl';
-
-require '/etc/debbugs/config';
-require '/etc/debbugs/text';
-
-use vars qw($gPackagePages $gWebDomain);
-
-if (defined $ENV{REQUEST_METHOD} and $ENV{REQUEST_METHOD} eq 'HEAD') {
- print "Content-Type: text/html; charset=utf-8\n\n";
- exit 0;
-}
-
-my $path = $ENV{PATH_INFO};
-
-if ($path =~ m,^/(\d+)(/(\d+)(/.*)?)?$,) {
- my $bug = $1;
- my $msg = $3;
- my $rest = $4;
-
- my @args = ("bug=$bug");
- push @args, "msg=$msg" if (defined $msg);
- if ($rest eq "") {
- 1;
- } elsif ($rest eq "/mbox") {
- push @args, "mbox=yes";
- } elsif ($rest =~ m,^/att/(\d+)(/[^/]+)?$,) {
- push @args, "att=$1";
- push @args, "filename=$2" if (defined $2);
- } else {
- bad_url();
- }
-
- { $ENV{"PATH"}="/bin"; exec "./bugreport.cgi", "leeturls=yes", @args; }
-
- print "Content-Type: text/html; charset=utf-8\n\n";
- print "<p>Couldn't execute bugreport.cgi!!";
- exit(0);
-} else {
- my $suite;
- my $arch;
- if ($path =~ m,^/suite/([^/]*)(/.*)$,) {
- $suite = $1; $path = $2;
- } elsif ($path =~ m,^/arch/([^/]*)(/.*)$,) {
- $arch = $1; $path = $2;
- } elsif ($path =~ m,^/suite-arch/([^/]*)/([^/]*)(/.*)$,) {
- $suite = $1; $arch = $2; $path = $3;
- }
-
- my $type;
- my $what;
- my $selection;
- if ($path =~ m,^/(package|source|maint|submitter|severity|tag|user-tag)/([^/]+)(/(.*))?$,) {
- $type = $1; $what = $2; $selection = $4 || "";
- if ($selection ne "") {
- unless ($type =~ m,^(package|source|user-tag)$,) {
- bad_url();
- }
- }
- my @what = split /,/, $what;
- my @selection = split /,/, $selection;
- my $typearg = $type;
- $typearg = "pkg" if ($type eq "package");
- $typearg = "src" if ($type eq "source");
-
- my @args = ();
- push @args, $typearg . "=" . join(",", @what);
- push @args, "version=" . join(",", @selection)
- if ($type eq "package" and $#selection >= 0);
- push @args, "utag=" . join(",", @selection)
- if ($type eq "user-tag" and $#selection >= 0);
- push @args, "arch=" . $arch if (defined $arch);
- push @args, "suite=" . $suite if (defined $suite);
-
- { $ENV{"PATH"}="/bin"; exec "./pkgreport.cgi", "leeturls=yes", @args }
-
- print "Content-Type: text/html; charset=utf-8\n\n";
- print "<p>Couldn't execute pkgreport.cgi!!";
- exit(0);
- } else {
- bad_url();
- }
-}
-
-sub bad_url {
- print "Content-Type: text/html; charset=utf-8\n\n";
- print "<p>Bad URL :(\n";
- exit(0);
-}
newer versions of SOAP::Lite. (Closes: #785405)
* Add patch to do singular/plural in error messages from Rafael.
(Closes: #790716)
+ * Fix (and test) setting summary/outlook in Control: messages (Closes:
+ #836613).
+ * Fix clone removing all other blocks instead of adding them (Closes:
+ #820044). Thanks to James Clarke.
+ * Use a supported version of debhelper and switch to dh $@ style rules
+ (Closes: #800287)
+ * debbugs-web now Breaks/Replaces debbugs (<< 2.4.2) (Closes: #717967)
+ * Split source file properly (Closes: #858671). Thanks to James McCoy.
+ * Prefix 'src:' to all source package names.
+ * cdn.libravatar.org no longer sends Content-Type. Switch to verifying
+ the content-type using libmagic instead (which we probably should have
+ been doing from the beginning anyway). (Closes: #856991)
+ * Reply sent messages (-forwarded and -done) are not informational messages.
+ (Closes: #864725)
+ * Pluralize singular tag and usertag in pseudoheaders (Closes: #861234).
+ Thanks to James Clarke
+ * Include link to the location of the debbugs source (Closes: #721569).
+ * Add envelope_from configuration variable so sites can set a valid return
+ path if the sendmail default is wrong. (Closes: #719205)
+ * Fix links to merged and blocked bugs. (Closes: #539691)
+ * Strip out Mail-Followup-To: (Closes: #798092)
+
+ [ Niels Thykier ]
+ * quitcgi() now returns 400/500 status codes instead of 200 (Closes: #584922)
[Thanks to Arnout Engelen: ]
* Add Homepage (closes: #670555).
#517834)
* Ditch extra blank lines (closes: #494843)
* Handle ' ending links in Debbugs::CGI::Bugreport (closes: #539020)
+ * Forcibly wrap format flowed and other messages (closes: #601242)
+ * Add a link to ack_thanks in process (Closes: #863274)
-- Don Armstrong <don@debian.org> Sun, 26 Jul 2009 05:48:16 -0700
Standards-Version: 3.9.4
Vcs-Browser: http://bugs.debian.org/debbugs-source/mainline
Vcs-Git: http://bugs.debian.org/debbugs-source/debbugs.git
-Build-Depends: debhelper (>= 5)
+Build-Depends: debhelper (>= 9)
Build-Depends-Indep: libparams-validate-perl,
libmailtools-perl, libmime-tools-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, libtest-pod-perl, liblist-moreutils-perl,
- libtext-template-perl, graphviz,
+ libconfig-simple-perl, libtest-pod-perl, liblist-allutils-perl,
+# used by Debbugs::Libravatar and libravatar.cgi
+ libfile-libmagic-perl, libgravatar-url-perl, libwww-perl, imagemagick,
libdbix-class-perl, libdatetime-format-pg-perl,
- libdatetime-format-mail-perl
+ libdatetime-format-mail-perl,
+ libtext-template-perl, graphviz, libtext-iconv-perl
Homepage: http://wiki.debian.org/Teams/Debbugs
Package: debbugs
${perl:Depends},
${misc:Depends},
exim4 | mail-transport-agent,
- libdebbugs-perl,
-Recommends: debbugs-web
+ libdebbugs-perl
+Recommends: debbugs-web (>= 2.6~)
Suggests: spamassassin (>= 3.0), libcgi-alert-perl
Description: bug tracking system based on the active Debian BTS
Debian has a bug tracking system which files details of bugs reported by
Package: debbugs-web
Architecture: all
Depends:
+ ${perl:Depends},
${misc:Depends},
libdebbugs-perl, apache2 | httpd
Suggests: libcgi-alert-perl, libapache2-mod-perl2
+Replaces: debbugs (<< 2.4.2)
+Breaks: debbugs (<< 2.4.2)
Description: web scripts for 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
Package: debbugs-local
Architecture: all
Depends:
+ ${perl:Depends},
${misc:Depends},
libdebbugs-perl, debbugs-web, libconfig-simple-perl,
libuser-perl, rsync, libhttp-server-simple-perl, libnet-server-perl
#!/usr/bin/make -f
-# Made with the aid of dh_make, by Craig Small
-# Sample debian/rules that uses debhelper. GNU copyright 1997 by Joey Hess.
-# Some lines taken from debmake, by Cristoph Lameter.
-# Uncomment this to turn on verbose mode.
-#export DH_VERBOSE=1
+%:
+ dh $@ --parallel
-DEST_DIR := $(CURDIR)/debian/tmp
-PERL ?= /usr/bin/perl
-
-
-build: build-arch build-indep
-
-build-arch:
-# nothing to do, as there aren't any architecture-dependent packages
-
-build-indep: build-stamp
-
-build-stamp:
-# Call the test suite
- $(PERL) Makefile.PL INSTALLDIRS=vendor
- $(MAKE) -f Makefile.perl
- $(MAKE) test
- touch $@
-
-clean:
- dh_testdir
- dh_testroot
- rm -f *-stamp;
- if [ -e Makefile.perl ]; then \
- $(MAKE) -f Makefile.perl clean; \
- fi;
- #something to remove all trace and *.trace files?
- rm -f debbugs.trace Makefile.perl.old
- dh_clean
-
-install: install-stamp
-install-stamp: build
- dh_testroot
- dh_clean -k
- dh_installdirs
- $(MAKE) install_mostfiles DESTDIR=$(DEST_DIR)
- $(MAKE) -f Makefile.perl install DESTDIR=$(DEST_DIR)
- touch $@
-
-binary-arch:
-# nothing to do, as there aren't any architecture-dependent packages
-
-binary-indep: build install
- dh_testdir
- dh_testroot
- dh_clean -k
- dh_installdirs
- $(MAKE) install_mostfiles DESTDIR=$(DEST_DIR)
- $(MAKE) -f Makefile.perl install DESTDIR=$(DEST_DIR)
- dh_install --sourcedir=debian/tmp --fail-missing
- dh_installdocs
- dh_installchangelogs
- dh_strip
- dh_fixperms
- #chown bugs.bugs $(var_dir)/spool/incoming
- dh_installdeb
- dh_perl
- dh_compress -X examples/text
- dh_shlibdeps
- dh_gencontrol
- dh_md5sums
- dh_builddeb
-
-
-binary: binary-indep binary-arch
-.PHONY: build clean install binary-indep binary-arch binary
+override_dh_auto_install:
+ dh_auto_install -- INSTALLDIRS=vendor
use strict;
use CGI qw(param remote_host);
-sub quitcgi($) {
- my $msg = shift;
+sub quitcgi($;$) {
+ my ($msg, $status) = @_;
+ $status //= '500 Internal Server Error';
+ print "Status: $status\n";
print "Content-Type: text/html\n\n";
print "<HTML><HEAD><TITLE>Error</TITLE></HEAD><BODY>\n";
print "An error occurred. Dammit.\n";
exit 0;
}
-my $bug = param('bug') or quitcgi('No bug specfied');
-quitcgi('No valid bug number') unless $bug =~ /^\d{3,6}$/;
+my $bug = param('bug') or quitcgi('No bug specfied', '400 Bad Request');
+quitcgi('No valid bug number', '400 Bad Request') unless $bug =~ /^\d{3,6}$/;
my $remote_host = remote_host or quitcgi("No remote host");
my $ok = param('ok');
if (not defined $ok) {
use Debbugs::Bugs qw(count_bugs);
use Debbugs::Status qw(get_bug_status);
-require '/org/bugs.debian.org/cgi-bin/common.pl';
-
package main;
my $startdate = time;
open OLDBUGS, '> /org/bugs.debian.org/www/stats/oldbugs.html.new'
or die "can't open oldbugs.html.new: $!";
+binmode(OLDBUGS,':encoding(UTF-8)');
print OLDBUGS <<EOF or die "can't write to oldbugs.html.new: $!";
<html><head><title>Bugs Over Two Years Old</title></head>
<body>
+++ /dev/null
-#! /usr/bin/perl -w
-use strict;
-use MLDBM qw(DB_File Storable);
-use Fcntl;
-
-$MLDBM::DumpMeth=q(portable);
-
-my %db;
-my %db2;
-tie %db, "MLDBM", "versions.idx.new", O_CREAT|O_RDWR, 0664
- or die "tie versions.idx.new: $!";
-tie %db2, "MLDBM", "versions_time.idx.new",O_CREAT|O_RDWR, 0664
- or die "tie versions_time.idx.new failed: $!";
-
-my $archive = shift;
-my $dist = shift;
-my $arch = shift;
-print "$archive/$dist/$arch\n";
-
-my $time = time;
-my ($p, $v);
-my $extra_source_only = 0;
-while (<>) {
- if (/^Package: (.*)/) { $p = $1; }
- elsif (/^Version: (.*)/) { $v = $1; }
- elsif (/^Extra-Source-Only: yes/) {
- $extra_source_only = 1;
- }
- elsif (/^$/) {
- if ($extra_source_only) {
- $extra_source_only = 0;
- next;
- }
- update_package_version($p,$v,$time);
- }
-}
-update_package_version($p,$v,$time) unless $extra_source_only;
-
-sub update_package_version {
- my ($p,$v,$t) = @_;
- # see MLDBM(3pm)/BUGS
- my $tmp = $db{$p};
- # we allow multiple versions in an architecture now; this
- # should really only happen in the case of source, however.
- push @{$tmp->{$dist}{$arch}}, $v;
- $db{$p} = $tmp;
- $tmp = $db2{$p};
- $tmp->{$dist}{$arch}{$v} = $time if not exists
- $tmp->{$dist}{$arch}{$v};
- $db2{$p} = $tmp;
-}
-
--- /dev/null
+#!/usr/bin/perl
+# build-versions-db builds the versions mldmb database
+# and is released under the terms of the GNU GPL version 3, or any
+# later version, at your option. See the file README and COPYING for
+# more information.
+# Copyright 2016 by Don Armstrong <don@donarmstrong.com>.
+
+
+use warnings;
+use strict;
+
+use Getopt::Long;
+use Pod::Usage;
+
+=head1 NAME
+
+build-versions-db -- builds source and source maintainers file
+
+=head1 SYNOPSIS
+
+ build-versions-db [options] versions.idx.new versions.idx.new \
+ /srv/bugs.debian.org/versions/indices/ftp
+
+ Options:
+ --debug, -d debugging level (Default 0)
+ --help, -h display this help
+ --man, -m display manual
+
+=head1 OPTIONS
+
+=over
+
+=item B<--update>
+
+Update an existing database; the default. B<--no-update> will regenerate an
+existing database from scratch.
+
+=item B<--debug, -d>
+
+Debug verbosity. (Default 0)
+
+=item B<--help, -h>
+
+Display brief usage information.
+
+=item B<--man, -m>
+
+Display this manual.
+
+=back
+
+=head1 EXAMPLES
+
+ build-versions-db versions.idx.new versions.idx.new \
+ /srv/bugs.debian.org/versions/indices/ftp \
+ stable
+
+=cut
+
+
+use vars qw($DEBUG);
+use Debbugs::Versions::Dpkg;
+use Debbugs::Config qw(:config);
+use File::Copy;
+use MLDBM qw(DB_File Storable);
+use Fcntl;
+
+my %options = (debug => 0,
+ help => 0,
+ man => 0,
+ update => 1,
+ );
+
+GetOptions(\%options,
+ 'update!',
+ 'debug|d+','help|h|?','man|m');
+
+pod2usage() if $options{help};
+pod2usage({verbose=>2}) if $options{man};
+
+$DEBUG = $options{debug};
+
+my @USAGE_ERRORS;
+
+if (not @ARGV >= 4) {
+ push @USAGE_ERRORS,
+ "You must provide at least four arguments, two databases, ".
+ "a top level directory and at least one suite";
+}
+
+
+pod2usage(join("\n",@USAGE_ERRORS)) if @USAGE_ERRORS;
+
+
+my $versions = shift @ARGV;
+my $versions_time = shift @ARGV;
+my $versions_new = $versions."_".$$."_".time;
+my $versions_time_new = $versions_time."_".$$."_".time;
+my $toplevel = shift @ARGV;
+my @suites = @ARGV;
+
+$MLDBM::DumpMeth=q(portable);
+
+my $time = time;
+
+my %db;
+my %db2;
+if ($options{update}) {
+ copy($versions_time,$versions_time_new);
+}
+tie %db, "MLDBM", $versions_new, O_CREAT|O_RDWR, 0664
+ or die "tie $versions: $!";
+tie %db2, "MLDBM", $versions_time_new,O_CREAT|O_RDWR, 0664
+ or die "tie $versions_time failed: $!";
+
+update_versions_suites(\%db,\%db2,\@suites);
+versions_time_cleanup(\%db2) if $options{update};
+
+move($versions_new,$versions);
+move($versions_time_new,$versions_time);
+
+sub open_compressed_file {
+ my ($file) = @_;
+ my $fh;
+ my $mode = '<:encoding(UTF-8)';
+ my @opts;
+ if ($file =~ /\.gz$/) {
+ $mode = '-|:encoding(UTF-8)';
+ push @opts,'gzip','-dc';
+ }
+ if ($file =~ /\.xz$/) {
+ $mode = '-|:encoding(UTF-8)';
+ push @opts,'xz','-dc';
+ }
+ if ($file =~ /\.bz2$/) {
+ $mode = '-|:encoding(UTF-8)';
+ push @opts,'bzip2','-dc';
+ }
+ open($fh,$mode,@opts,$file);
+ return $fh;
+}
+
+# Read Package, Version, and Source fields from a Packages.gz file.
+sub read_packages {
+ my ($db,$db2,$packages, $component,$arch,$dist) = @_;
+ my $PACKAGES = open_compressed_file($packages) or
+ die "Unable to open $packages for reading: $!";
+ local $_;
+ local $/ = ''; # paragraph mode
+
+ print STDERR "reading packages $packages\n" if $DEBUG;
+ for (<$PACKAGES>) {
+ /^Package: (.+)/im or next;
+ my $pkg = $1;
+ /^Version: (.+)/im or next;
+ my $ver = $1;
+ my $extra_source_only = 0;
+ if (/^Extra-Source-Only: yes/im) {
+ $extra_source_only = 1;
+ }
+ update_package_version($db,$db2,$dist,$arch,$pkg,$ver,$time) unless
+ $extra_source_only;
+ }
+ close($PACKAGES) or
+ die "Error while closing ${packages}: $!";
+}
+
+
+sub update_package_version {
+ my ($db,$db2,$d,$a,$p,$v,$t) = @_;
+ # see MLDBM(3pm)/BUGS
+ my $tmp = $db->{$p};
+ # we allow multiple versions in an architecture now; this
+ # should really only happen in the case of source, however.
+ push @{$tmp->{$d}{$a}}, $v;
+ $db->{$p} = $tmp;
+ $tmp = $db2->{$p};
+ $tmp->{$d}{$a}{$v} = $time if not exists
+ $tmp->{$d}{$a}{$v};
+ $db2->{$p} = $tmp;
+}
+
+sub update_versions_suites {
+ my ($db,$db2,$suites) = @_;
+# Iterate through all Packages and Sources files.
+for my $suite (@{$suites}) {
+ my $suitedir = "$toplevel/$suite";
+
+ for my $component ('main', 'main/debian-installer',
+ 'contrib', 'non-free') {
+ my $componentdir = "$suitedir/$component";
+ next unless -d $componentdir;
+ my $COMPONENT;
+ opendir $COMPONENT, $componentdir or die "opendir $componentdir: $!";
+
+ # debian-installer is really a section rather than a component
+ # (ugh).
+ (my $viscomponent = $component) =~ s[/.*][];
+
+ my $sources = (grep { -f $_ } glob "$suitedir/$component/source/Sources.*")[0];
+ next unless defined $sources;
+ read_packages($db,$db2,$sources, $viscomponent,'source',$suite);
+
+ for my $arch (readdir $COMPONENT) {
+ next unless $arch =~ s/^binary-//;
+ my $archdir = "$componentdir/binary-$arch";
+
+ my $packages = (grep { -f $_ } glob("$archdir/Packages.*"))[0];
+ next unless defined $packages;
+ read_packages($db,$db2,$packages, $viscomponent,$arch,$suite);
+ }
+
+ closedir $COMPONENT or
+ die "Unable to closedir $componentdir: $!";
+ }
+}
+}
+
+sub versions_time_cleanup {
+ my ($db) = @_;
+ my $time = time;
+ for my $package (keys %{$db}) {
+ my $temp = $db->{$package};
+ for my $dist (keys %{$temp}) {
+ for my $arch (keys %{$temp->{$dist}}) {
+ my @versions = (sort {$temp->{$dist}{$arch}{$a} <=>
+ $temp->{$dist}{$arch}{$b}
+ }
+ keys %{$temp->{$dist}{$arch}});
+ next unless @versions > 1;
+ for my $i (0 .. ($#versions-1)) {
+ last if $temp->{$dist}{$arch}{$versions[$i+1]} >
+ ($time - $config{remove_age}*60*60*24);
+ last if keys %{$temp->{$dist}{$arch}} <= 1;
+ delete $temp->{$dist}{$arch}{$versions[$i]};
+ }
+ }
+ }
+ $db->{$package} = $temp;
+ }
+}
ARCHIVES='ftp' # security -- should be included too, but too difficult to deal with
-# Nuke old versions of versions.idx.new in case there's one hanging about
-rm -f versions.idx.new
-# This index is much larger and keeps track of historic versions of
-# packages, and is used for expiring bugs
-rm -f versions_time.idx.new
-if [ -e versions_time.idx ]; then
- cp versions_time.idx versions_time.idx.new;
-fi;
-
-set -e
-for archive in $ARCHIVES; do
- case $archive in
- ftp)
- SUITES='oldstable stable proposed-updates testing testing-proposed-updates unstable experimental'
- di_main='main main/debian-installer'
- ;;
- nonus)
- SUITES='oldstable'
- di_main='main'
- ;;
- security)
- SUITES='oldstable stable testing'
- di_main='main'
- ;;
- esac
- for suite in $SUITES; do
- if [ "$suite" != "oldstable" ] || [ -d /org/bugs.debian.org/etc/indices/$archive/$suite ]; then
- case $suite in
- oldstable|stable|proposed-updates)
- ARCHES='alpha amd64 arm hppa i386 ia64 m68k mips mipsel powerpc s390 sparc'
- ;;
- testing|testing-proposed-updates)
- ARCHES='alpha amd64 arm hppa i386 ia64 mips mipsel powerpc s390 sparc'
- ;;
- unstable|experimental)
- ARCHES='alpha amd64 arm hppa hurd-i386 i386 ia64 m68k mips mipsel powerpc s390 sparc'
- ;;
- esac
- case $suite in
- oldstable|experimental)
- COMPONENTS='main contrib non-free'
- ;;
- stable|proposed-updates|testing|testing-proposed-updates|unstable)
- COMPONENTS="$di_main contrib non-free"
- ;;
- esac
- for component in $COMPONENTS; do
- for arch in $ARCHES; do
- zcat "/org/bugs.debian.org/etc/indices/$archive/$suite/$component/binary-$arch/Packages.gz" | ../bin/build-mldbm.pl "$archive" "$suite" "$arch"
- done
- if [ "$component" != main/debian-installer ]; then
- zcat "/org/bugs.debian.org/etc/indices/$archive/$suite/$component/source/Sources.gz" | ../bin/build-mldbm.pl "$archive" "$suite" source
- fi
- done
- fi
- done
-done
-
-# This removes old versions
-../bin/versions_time_cleanup
-
-chmod 664 versions.idx.new
-mv versions.idx.new versions.idx
-
-chmod 664 versions_time.idx.new
-mv versions_time.idx.new versions_time.idx
\ No newline at end of file
+../bin/build-versions-db versions.idx versions_time.idx \
+ /srv/bugs.debian.org/versions/indices/ftp \
+ oldstable stable proposed-updates \
+ testing \
+ testing-proposed-updates \
+ unstable \
+ experimental;
padding-top: 8px;
margin-top: 0;
border-top: 0;
+ white-space: pre-wrap;
+}
+
+pre.wrapping {
+ width: 80ch;
}
.sparse li {
color: #686868;
}
+.msgreceived p {
+ width: 120ch;
+ margin-top: 0px;
+ margin-bottom: 0px;
+}
+
+p.msgreceived {
+ width: 120ch;
+ margin-top: 0px;
+ margin-bottom: 0px;
+}
+
.buginfo p
{
font-family: sans-serif;
<p>Find a bug by <strong>number</strong>:
<br>
- <form method="get" action="http://$gCGIDomain/bugreport.cgi">
+ <form method="get" action="$gCGIDomain/bugreport.cgi">
<input type="text" size="9" name="bug" value="">
<input type="submit" value="Find">
<input type="checkbox" name="mbox" value="yes"> as mbox
</form>
-<form method="get" action="http://$gCGIDomain/pkgreport.cgi">
+<form method="get" action="$gCGIDomain/pkgreport.cgi">
<p>Find bugs by:
<input type="radio" name="which" value="pkg" checked><strong>package</strong>
<input type="radio" name="which" value="src"><strong>source package</strong>
<p>The following bug report indices are available:
<ul>
<li>Packages with
- <a href="http://$gCGIDomain/pkgindex.cgi?indexon=pkg">active</a>
+ <a href="$gCGIDomain/pkgindex.cgi?indexon=pkg">active</a>
and
- <a href="http://$gCGIDomain/pkgindex.cgi?indexon=pkg&archived=yes">archived</a>
+ <a href="$gCGIDomain/pkgindex.cgi?indexon=pkg&archived=yes">archived</a>
bug reports.
<li>Source packages with
- <a href="http://$gCGIDomain/pkgindex.cgi?indexon=src">active</a>
+ <a href="$gCGIDomain/pkgindex.cgi?indexon=src">active</a>
and
- <a href="http://$gCGIDomain/pkgindex.cgi?indexon=src&archived=yes">archived</a>
+ <a href="$gCGIDomain/pkgindex.cgi?indexon=src&archived=yes">archived</a>
bug reports.
<li>Maintainers of packages with
- <a href="http://$gCGIDomain/pkgindex.cgi?indexon=maint">active</a>
+ <a href="$gCGIDomain/pkgindex.cgi?indexon=maint">active</a>
and
- <a href="http://$gCGIDomain/pkgindex.cgi?indexon=maint&archived=yes">archived</a>
+ <a href="$gCGIDomain/pkgindex.cgi?indexon=maint&archived=yes">archived</a>
bug reports.
<li>Submitters of
- <a href="http://$gCGIDomain/pkgindex.cgi?indexon=submitter">active</a>
+ <a href="$gCGIDomain/pkgindex.cgi?indexon=submitter">active</a>
and
- <a href="http://$gCGIDomain/pkgindex.cgi?indexon=submitter&archived=yes">archived</a>
+ <a href="$gCGIDomain/pkgindex.cgi?indexon=submitter&archived=yes">archived</a>
bug reports.
</ul>
<p>In case you are reading this as a plain text file or via email: an
HTML version is available via the $gBug system main contents page
-<code>http://$gWebDomain/</code>.
+<code>$gWebDomain/</code>.
<hr>
$gEmailDomain = "bugs.top.domain"; #bugs.debian.org
$gListDomain = "lists.top.domain"; #lists.debian.org
$gWebHostBugDir = "";
-$gWebDomain = "www.top.domain"; #www.debian.org/Bugs
+$gWebDomain = "https://www.top.domain"; #www.debian.org/Bugs
$gCGIDomain = "cgi.top.domain"; #cgi.debian.org
#Identification
use Pod::Usage;
use File::stat;
-use List::Util qw(min);
+use List::AllUtils qw(min);
use Debbugs::Common qw(make_list);
Please see the documentation for more information about how to
use the $gBug tracking system. It is available on the WWW at
-<A HREF=\"http://$gWebDomain/txt/\">$gWebDomain/txt</A>
+<A HREF=\"$gWebDomain/txt/\">$gWebDomain/txt</A>
END
close(D);
$_ = $hdr;
s/\n\s/ /g;
finish() if m/^x-loop: (\S+)$/i && $1 eq "$gMaintainerEmail";
- my $ins = !m/^subject:/i && !m/^reply-to:/i && !m/^return-path:/i
- && !m/^From / && !m/^X-Debbugs-/i;
+ my $ins = !m/^(?:(?:subject|reply-to|return-path|mail-followup-to):
+ |From\s|X-Debbugs-)/xi;
$fwd .= encode_utf8($hdr)."\n" if $ins;
# print {$debugfh} ">$_<\n";
if (s/^(\S+):\s*//) {
# Fixes #488554
$phline =~ s/\xef\xbb\xbf//g;
$phline =~ s/\N{U+FEFF}//g;
- last if $phline !~ m/^([\w-]+):\s*(\S.*)/;
+ last if $phline !~ m/^([\w-]+): # psuedoheader
+ (?:\s|\N{U+00A0})* # zero or more spaces, including
+ # non-breaking space
+ (\S.*)/x; # pseudoheader value
my ($fn, $fv) = ($1, $2);
$fv =~ s/\s*$//;
+ # pluralize tag/usertag
+ $fn = $fn.'s' if $fn =~ /^(?:tag|usertag)$/;
print {$debugfh} ">$fn|$fv|\n";
$fn = lc $fn;
if ($fn =~ /^control$/) {
"X-$gProject-PR-Keywords" => $data->{keywords},
# Only have a X-$gProject-PR-Source when we know the source package
(defined($source_package) and length($source_package))?("X-$gProject-PR-Source" => $source_package):(),
+ "Reply-To" => "$ref\@$gEmailDomain",
+ "Content-Type" => 'text/plain; charset="utf-8"',
],message_body_template('mail/process_mark_as_forwarded',
{date => $header{date},
messageid => $header{'message-id'},
"X-$gProject-PR-Keywords" => $data->{keywords},
# Only have a X-$gProject-PR-Source when we know the source package
(defined($source_package) and length($source_package))?("X-$gProject-PR-Source" => $source_package):(),
+ "Reply-To" => "$ref\@$gEmailDomain",
+ "Content-Type" => 'text/plain; charset="utf-8"',
],message_body_template('mail/process_mark_as_done',
{date => $header{date},
messageid => $header{'message-id'},
if (defined $pheader{source}) {
# source packages are identified by the src: prefix
- $data->{package} = 'src:'.$pheader{source};
+ $data->{package} = $pheader{source};
+ $data->{package} =~ s/(^|,\s*)/${1}src:/g;
} elsif (defined $pheader{package}) {
$data->{package} = $pheader{package};
if ($data->{package} =~ /^src:(.+)/) {
request_subject => $header{subject},
request_nn => $nn,
request_replyto => $replyto,
- message => $msg,
+ message => [$msg],
affected_bugs => \%bug_affected,
affected_packages => \%affected_packages,
recipients => \%recipients,
};
my $hole_var = {'&bugurl' =>
sub{"$_[0]: ".
- 'http://'.$config{cgi_domain}.'/'.
+ $config{cgi_domain}.'/'.
Debbugs::CGI::bug_links(bug=>$_[0],
links_only => 1,
);
$gBadEmailPrefix (all \@$gEmailDomain.)
$gBadEmailPrefix
$gBadEmailPrefix For instructions via the WWW see:
-$gBadEmailPrefix http://$gWebDomain/
-$gBadEmailPrefix http://$gWebDomain/Reporting$gHTMLSuffix
-$gBadEmailPrefix http://$gWebDomain/Developer$gHTMLSuffix
-$gBadEmailPrefix http://$gWebDomain/Access$gHTMLSuffix
+$gBadEmailPrefix $gWebDomain/
+$gBadEmailPrefix $gWebDomain/Reporting$gHTMLSuffix
+$gBadEmailPrefix $gWebDomain/Developer$gHTMLSuffix
+$gBadEmailPrefix $gWebDomain/Access$gHTMLSuffix
$gTextInstructions
$gBadEmailPrefix For details of how to access $gBug report logs by email:
$gBadEmailPrefix send \`request\@$gEmailDomain' the word \`help'
use Scalar::Util qw(looks_like_number);
-use List::Util qw(first);
+use List::AllUtils qw(first);
use Mail::RFC822::Address;
use Encode qw(decode encode);
} elsif (m/^subscribe/i) {
print {$transcript} <<END;
There is no $gProject $gBug mailing list. If you wish to review bug reports
-please do so via http://$gWebDomain/ or ask this mail server
+please do so via $gWebDomain or ask this mail server
to send them to you.
soon: MAILINGLISTS_TEXT
END
};
my $hole_var = {'&bugurl' =>
sub{"$_[0]: ".
- 'http://'.$config{cgi_domain}.'/'.
+ $config{cgi_domain}.'/'.
Debbugs::CGI::bug_links(bug=>$_[0],
links_only => 1,
);
sub sendlynxdocraw {
my ($relpath,$description) = @_;
$doc='';
- open(L,"lynx -nolist -dump http://$gCGIDomain/\Q$relpath\E 2>&1 |") || die "fork for lynx: $!";
+ open(L,"lynx -nolist -dump $gCGIDomain/\Q$relpath\E 2>&1 |") || die "fork for lynx: $!";
while(<L>) { $doc.=$_; }
$!=0; close(L);
if ($? == 255 && $doc =~ m/^\n*lynx: Can\'t access start file/) {
<!--timestamp-->
<P>
- <A HREF=\"http://$gWebDomain/\">Debian $gBug tracking system</A><BR>
+ <A HREF=\"$gWebDomain/\">Debian $gBug tracking system</A><BR>
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.
result => -1,
relation => 'lt',
},
- {a => '1foo-',
- b => '1foo',
- result => 0,
- relation => 'eq',
- },
- {a => '1foo-',
- b => '1foo+',
- result => -1,
- relation => 'lt',
- },
);
plan tests => @versions * 2 + 1;
# HTTP::Server:::Simple defines a SIG{CHLD} handler that breaks system; undef it here.
$SIG{CHLD} = sub {};
-my %config;
-eval {
- %config = create_debbugs_configuration(debug => exists $ENV{DEBUG}?$ENV{DEBUG}:0);
-};
-if ($@) {
- BAIL_OUT($@);
-}
+my %config = create_debbugs_configuration();
+
my $sendmail_dir = $config{sendmail_dir};
my $spool_dir = $config{spool_dir};
my $config_dir = $config{config_dir};
-END{
- if ($ENV{DEBUG}) {
- diag("spool_dir: $spool_dir\n");
- diag("config_dir: $config_dir\n");
- diag("sendmail_dir: $sendmail_dir\n");
- }
-}
+
# We're going to use create mime message to create these messages, and
# then just send them to receive.
use lib qw(t/lib);
use DebbugsTest qw(:all);
-my %config;
-eval {
- %config = create_debbugs_configuration(debug => exists $ENV{DEBUG}?$ENV{DEBUG}:0);
-};
-if ($@) {
- BAIL_OUT($@);
-}
+my %config = create_debbugs_configuration();
-# Output some debugging information if there's an error
-END{
- if ($ENV{DEBUG}) {
- foreach my $key (keys %config) {
- diag("$key: $config{$key}\n");
- }
- }
-}
# create a bug
send_message(to=>'submit@bugs.something',
# HTTP::Server:::Simple defines a SIG{CHLD} handler that breaks system; undef it here.
$SIG{CHLD} = sub {};
-my %config;
-eval {
- %config = create_debbugs_configuration(debug => exists $ENV{DEBUG}?$ENV{DEBUG}:0);
-};
-if ($@) {
- BAIL_OUT($@);
-}
+my %config = create_debbugs_configuration();
+
my $sendmail_dir = $config{sendmail_dir};
my $spool_dir = $config{spool_dir};
my $config_dir = $config{config_dir};
-END{
- if ($ENV{DEBUG}) {
- diag("spool_dir: $spool_dir\n");
- diag("config_dir: $config_dir\n");
- diag("sendmail_dir: $sendmail_dir\n");
- }
-}
+
# We're going to use create mime message to create these messages, and
# then just send them to receive.
use lib qw(t/lib);
use DebbugsTest qw(:all);
-my %config;
-eval {
- %config = create_debbugs_configuration(debug => exists $ENV{DEBUG}?$ENV{DEBUG}:0);
-};
-if ($@) {
- BAIL_OUT($@);
-}
-
-# Output some debugging information if there's an error
-END{
- if ($ENV{DEBUG}) {
- foreach my $key (keys %config) {
- diag("$key: $config{$key}\n");
- }
- }
-}
+my %config = create_debbugs_configuration();
+
# create a bug
send_message(to=>'submit@bugs.something',
my $pkgreport_cgi_handler = sub {
# I do not understand why this is necessary.
$ENV{DEBBUGS_CONFIG_FILE} = "$config{config_dir}/debbugs_config";
- # We cd here because pkgreport uses require ./common.pl
- my $content = qx(cd cgi; perl -I.. -T pkgreport.cgi);
+ my $content = qx(perl -I. -T cgi/pkgreport.cgi);
# Strip off the Content-Type: stuff
$content =~ s/^\s*Content-Type:[^\n]+\n*//si;
print $content;
use DebbugsTest qw(:configuration);
use Cwd;
-my %config;
-eval {
- %config = create_debbugs_configuration(debug => exists $ENV{DEBUG}?$ENV{DEBUG}:0);
-};
-if ($@) {
- BAIL_OUT($@);
-}
+my %config = create_debbugs_configuration();
-# Output some debugging information if we're debugging
-END{
- if ($ENV{DEBUG}) {
- foreach my $key (keys %config) {
- diag("$key: $config{$key}\n");
- }
- }
-}
# create a bug
send_message(to=>'submit@bugs.something',
# HTTP::Server:::Simple defines a SIG{CHLD} handler that breaks system; undef it here.
$SIG{CHLD} = sub {};
-my %config;
-eval {
- %config = create_debbugs_configuration(debug => exists $ENV{DEBUG}?$ENV{DEBUG}:0);
-};
-if ($@) {
- BAIL_OUT($@);
-}
+my %config = create_debbugs_configuration();
+
my $sendmail_dir = $config{sendmail_dir};
my $spool_dir = $config{spool_dir};
my $config_dir = $config{config_dir};
-END{
- if ($ENV{DEBUG}) {
- diag("spool_dir: $spool_dir\n");
- diag("config_dir: $config_dir\n");
- diag("sendmail_dir: $sendmail_dir\n");
- }
-}
+
# We're going to use create mime message to create these messages, and
# then just send them to receive.
# HTTP::Server:::Simple defines a SIG{CHLD} handler that breaks system; undef it here.
$SIG{CHLD} = sub {};
-my %config;
-eval {
- %config = create_debbugs_configuration(debug => exists $ENV{DEBUG}?$ENV{DEBUG}:0);
-};
-if ($@) {
- BAIL_OUT($@);
-}
+my %config = create_debbugs_configuration();
+
my $sendmail_dir = $config{sendmail_dir};
my $spool_dir = $config{spool_dir};
my $config_dir = $config{config_dir};
-END{
- if ($ENV{DEBUG}) {
- diag("spool_dir: $spool_dir\n");
- diag("config_dir: $config_dir\n");
- diag("sendmail_dir: $sendmail_dir\n");
- }
-}
+
# We're going to use create mime message to create these messages, and
# then just send them to receive.
# HTTP::Server:::Simple defines a SIG{CHLD} handler that breaks system; undef it here.
$SIG{CHLD} = sub {};
-my %config;
-eval {
- %config = create_debbugs_configuration(debug => exists $ENV{DEBUG}?$ENV{DEBUG}:0);
-};
-if ($@) {
- BAIL_OUT($@);
-}
+my %config = create_debbugs_configuration();
+
my $sendmail_dir = $config{sendmail_dir};
my $spool_dir = $config{spool_dir};
my $config_dir = $config{config_dir};
-END{
- if ($ENV{DEBUG}) {
- diag("spool_dir: $spool_dir\n");
- diag("config_dir: $config_dir\n");
- diag("sendmail_dir: $sendmail_dir\n");
- }
-}
+
# We're going to use create mime message to create these messages, and
# then just send them to receive.
# HTTP::Server:::Simple defines a SIG{CHLD} handler that breaks system; undef it here.
$SIG{CHLD} = sub {};
-my %config;
-eval {
- %config = create_debbugs_configuration(debug => exists $ENV{DEBUG}?$ENV{DEBUG}:0);
-};
-if ($@) {
- BAIL_OUT($@);
-}
+my %config = create_debbugs_configuration();
+
my $sendmail_dir = $config{sendmail_dir};
my $spool_dir = $config{spool_dir};
my $config_dir = $config{config_dir};
-END{
- if ($ENV{DEBUG}) {
- diag("spool_dir: $spool_dir\n");
- diag("config_dir: $config_dir\n");
- diag("sendmail_dir: $sendmail_dir\n");
- }
-}
+
# We're going to use create mime message to create these messages, and
# then just send them to receive.
# HTTP::Server:::Simple defines a SIG{CHLD} handler that breaks system; undef it here.
$SIG{CHLD} = sub {};
-my %config;
-eval {
- %config = create_debbugs_configuration(debug => exists $ENV{DEBUG}?$ENV{DEBUG}:0);
-};
-if ($@) {
- BAIL_OUT($@);
-}
+my %config = create_debbugs_configuration();
+
my $sendmail_dir = $config{sendmail_dir};
my $spool_dir = $config{spool_dir};
my $config_dir = $config{config_dir};
-END{
- if ($ENV{DEBUG}) {
- diag("spool_dir: $spool_dir\n");
- diag("config_dir: $config_dir\n");
- diag("sendmail_dir: $sendmail_dir\n");
- }
-}
+
# We're going to use create mime message to create these messages, and
# then just send them to receive.
# HTTP::Server:::Simple defines a SIG{CHLD} handler that breaks system; undef it here.
$SIG{CHLD} = sub {};
-my %config;
-eval {
- %config = create_debbugs_configuration(debug => exists $ENV{DEBUG}?$ENV{DEBUG}:0);
-};
-if ($@) {
- BAIL_OUT($@);
-}
+my %config = create_debbugs_configuration();
+
my $sendmail_dir = $config{sendmail_dir};
my $spool_dir = $config{spool_dir};
my $config_dir = $config{config_dir};
-END{
- if ($ENV{DEBUG}) {
- diag("spool_dir: $spool_dir\n");
- diag("config_dir: $config_dir\n");
- diag("sendmail_dir: $sendmail_dir\n");
- }
-}
+
# We're going to use create mime message to create these messages, and
# then just send them to receive.
$SIG{CHLD} = sub {};
our %config;
eval {
- %config = create_debbugs_configuration(debug => exists $ENV{DEBUG}?$ENV{DEBUG}:0);
+ %config = create_debbugs_configuration();
};
if ($@) {
BAIL_OUT($@);
}
$ENV{DEBBUGS_CONFIG_FILE} = "$config{config_dir}/debbugs_config";
-END{
- if ($ENV{DEBUG}) {
- diag("spool_dir: $config{spool_dir}\n");
- diag("config_dir: $config{config_dir}\n");
- diag("sendmail_dir: $config{sendmail_dir}\n");
- }
-}
my $libravatar_cgi_handler = sub {
my $fh;
--- /dev/null
+# -*- mode: cperl;-*-
+
+use Test::More;
+
+use warnings;
+use strict;
+
+# The test functions are placed here to make things easier
+use lib qw(t/lib);
+use DebbugsTest qw(:all);
+use Data::Dumper;
+
+my %config =
+ create_debbugs_configuration();
+
+my $sendmail_dir = $config{sendmail_dir};
+my $spool_dir = $config{spool_dir};
+
+# We're going to use create mime message to create these messages, and
+# then just send them to receive.
+
+send_message(to=>'submit@bugs.something',
+ headers => [To => 'submit@bugs.something',
+ From => 'foo@bugs.something',
+ Subject => 'Submiting a bug',
+ ],
+ body => <<EOF) or fail('Unable to send message');
+Package: foo
+Severity: normal
+
+This is a silly bug
+EOF
+
+# now we check to see that we have a bug, and nextnumber has been incremented
+ok(-e "$spool_dir/db-h/01/1.log",'log file created');
+ok(-e "$spool_dir/db-h/01/1.summary",'sumary file created');
+ok(-e "$spool_dir/db-h/01/1.status",'status file created');
+ok(-e "$spool_dir/db-h/01/1.report",'report file created');
+
+# next, we check to see that (at least) the proper messages have been
+# sent out. 1) ack to submitter 2) mail to maintainer
+
+# This keeps track of the previous size of the sendmail directory
+my $SD_SIZE = 0;
+$SD_SIZE =
+ num_messages_sent($SD_SIZE,2,
+ $sendmail_dir,
+ 'submit messages appear to have been sent out properly',
+ );
+
+
+# set the summary to "This is the summary of the silly bug"
+
+send_message(to => 'control@bugs.something',
+ headers => [To => 'control@bugs.something',
+ From => 'foo@bugs.something',
+ Subject => 'Munging a bug',
+ ],
+ body => <<EOF) or fail('sending message to 1@bugs.someting failed');
+summary 1 0
+thanks
+
+This is the summary of the silly bug
+
+This is not the summary of the silly bug
+EOF
+
+# now we need to check to make sure that the control message actually did anything
+# This is an eval because $ENV{DEBBUGS_CONFIG_FILE} isn't set at BEGIN{} time
+eval "use Debbugs::Status qw(read_bug writebug);";
+my $status = read_bug(bug=>1);
+is($status->{summary},"This is the summary of the silly bug",'bug 1 has right summary');
+
+send_message(to => '1@bugs.something',
+ headers => [To => '1@bugs.something',
+ From => 'foo@bugs.something',
+ Subject => 'Munging a bug',
+ ],
+ body => <<EOF) or fail('sending message to 1@bugs.someting failed');
+Control: summary -1 0
+
+This is a new summary.
+
+This is not the summary of the silly bug
+EOF
+
+$status = read_bug(bug=>1);
+is($status->{summary},"This is a new summary.",'Control: summary setting works');
+
+
+done_testing();
--- /dev/null
+# -*- mode: cperl;-*-
+
+use Test::More;
+
+use warnings;
+use strict;
+use utf8;
+
+# The test functions are placed here to make things easier
+use lib qw(t/lib);
+use DebbugsTest qw(:all);
+use Data::Dumper;
+
+my %config =
+ create_debbugs_configuration();
+
+my $sendmail_dir = $config{sendmail_dir};
+my $spool_dir = $config{spool_dir};
+
+# We're going to use create mime message to create these messages, and
+# then just send them to receive.
+
+send_message(to=>'submit@bugs.something',
+ headers => [To => 'submit@bugs.something',
+ From => 'foo@bugs.something',
+ Subject => 'Submiting a bug',
+ ],
+ body => <<EOF,
+Package: foo
+Severity: normal
+
+This is a silly bug
+EOF
+ attachments => [<<EOF]) or fail('Unable to send message');
+This is a silly attachment to make sure that pseudoheaders work
+EOF
+# now we check to see that we have a bug, and nextnumber has been incremented
+ok(-e "$spool_dir/db-h/01/1.log",'log file created');
+ok(-e "$spool_dir/db-h/01/1.summary",'sumary file created');
+ok(-e "$spool_dir/db-h/01/1.status",'status file created');
+ok(-e "$spool_dir/db-h/01/1.report",'report file created');
+
+# next, we check to see that (at least) the proper messages have been
+# sent out. 1) ack to submitter 2) mail to maintainer
+
+# This keeps track of the previous size of the sendmail directory
+my $SD_SIZE = 0;
+$SD_SIZE =
+ num_messages_sent($SD_SIZE,2,
+ $sendmail_dir,
+ 'submit messages appear to have been sent out properly',
+ );
+
+send_message(to=>'1-done@bugs.something',
+ headers => [To => '1-done@bugs.something',
+ From => 'foo@bugs.something',
+ Subject => 'Closing a bug with pseudoheaders',
+ ],
+ body => <<EOF,
+Source: foo
+Version: 1
+
+
+I've closed this silly bug; using an UTF-8 non-breaking space to test that
+https://bugs.debian.org/817128 was fixed too.
+EOF
+ attachments => [<<EOF,
+This is one silly attachment to make sure that pseudoheaders work
+EOF
+ <<EOF]) or fail('Unable to send message');
+And this is another, just in case.
+EOF
+
+# now we need to check to make sure that the control message actually did anything
+# This is an eval because $ENV{DEBBUGS_CONFIG_FILE} isn't set at BEGIN{} time
+eval "use Debbugs::Status qw(read_bug writebug);";
+my $status = read_bug(bug=>1);
+is($status->{done},'foo@bugs.something','bug 1 was closed properly');
+is_deeply($status->{fixed_versions},["1"],'bug 1 was fixed in the proper version');
+
+done_testing();
sub create_debbugs_configuration {
my %param = validate_with(params => \@_,
spec => {debug => {type => BOOLEAN,
- default => 0,
+ default => exists $ENV{DEBUG}?
+ $ENV{DEBUG}:0,
},
cleanup => {type => BOOLEAN,
optional => 1,
$ENV{DEBBUGS_CONFIG_FILE} ="$config_dir/debbugs_config";
$ENV{PERL5LIB} = getcwd();
$ENV{SENDMAIL_TESTDIR} = $sendmail_dir;
+ eval {
my $sendmail_tester = getcwd().'/t/sendmail_tester';
unless (-x $sendmail_tester) {
die q(t/sendmail_tester doesn't exist or isn't executable. You may be in the wrong directory.);
}
system('mkdir','-p',"$spool_dir/incoming");
system('mkdir','-p',"$spool_dir/lock");
+ eval '
+END{
+ if ($ENV{DEBUG}) {
+ diag("spool_dir: $spool_dir\n");
+ diag("config_dir: $config_dir\n",);
+ diag("sendmail_dir: $sendmail_dir\n");
+ }
+}';
+ };
+ BAIL_OUT ($@) if ($@);
return (spool_dir => $spool_dir,
sendmail_dir => $sendmail_dir,
config_dir => $config_dir,
}
}
+$SIG{CHLD} = sub {};
+
{
package DebbugsTest::HTTPServer;
use base qw(HTTP::Server::Simple::CGI HTTP::Server::Simple::CGI::Environment);
}
{$log}
<hr>
-<p class="msgreceived">Send a report that <a href="http://{$config{cgi_domain}}/bugspam.cgi?bug={$bug_num}">this bug log contains spam</a>.</p>
+<p class="msgreceived">Send a report that <a href="{$config{cgi_domain}}/bugspam.cgi?bug={$bug_num}">this bug log contains spam</a>.</p>
<hr>
{include(q(html/html_tail))}
</body>
<body>
<h1>{$config{project}} {$config{bug}} report logs - #{$bug_num}</h1>
<p>There is no record of {$config{bug}} #{$bug_num}.
-Try the <a href="http://{$config{web_domain}}/">search page</a> instead.</p>
+Try the <a href="{$config{web_domain}}/">search page</a> instead.</p>
{#include('html/html_tail')}
</body></html>
</td>
<td></td>
</tr>
-<tr><td><h2>Categorize using</h2></td>
-<td></td>
-</tr>
-<tr><td><h2>Order by</h2></td>
+<tr><td><h2>Categorize/<wbr>Order using</h2></td>
<td><select name="ordering">{ my $output = '';
- my @orderings = qw(normal oldview raw age);
- for my $order (@orderings) {
+ for my $order (@{$param{orderings}}) {
$output .= '<option value="'.$order.'"'.(($order eq $param{ordering})?' selected':'').
">$order</option>\n";
}
Machine Name:
<!--machinename-->{$config{machine_name}||'Unknown'}<!--machinename-->
<P>
-<A HREF="http://{$config{web_domain}}/">{$config{project}} {$config{bug}} tracking system</A><BR>
-Copyright (C) 1999 Darren O. Benham,
+<A HREF="{$config{web_domain}}/">{$config{project}} {$config{bug}} tracking system</A>
+</p>
+<p>
+ Debbugs is free software and licensed under the terms of the GNU
+ Public License version 2. The current version can be obtained
+ from <a href="https://bugs.debian.org/debbugs-source/">https://bugs.debian.org/debbugs-source/</a>.
+</p>
+<p>
+Copyright © 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
-1994-97 Ian Jackson.
-</P>
+1994-97 Ian Jackson,
+2005-2017 Don Armstrong, and many other contributors.
+</p>
</ADDRESS>
Thank you for filing a new {$config{bug}} report with {$config{project}}.
+
+You can follow progress on this {$config{bug}} here: {bugurl($ref)}.
with your problem report. Please _resubmit_ your report to
{$baddress}@{$config{email_domain}} and tell us which package the
report is for. For help, check out
-http://{$config{web_domain}}/Reporting{$config{html_suffix}}.
+{$config{web_domain}}/Reporting{$config{html_suffix}}.
Your message was dated {$date} and had
message-id {$messageid}
projects / debbugs.git / commitdiff