=item owner -- owner of the bug
+=item correspondent -- address of someone who sent mail to the log
+
=item dist -- distribution (I don't know about this one yet)
=item bugs -- list of bugs to search within
dist => {type => SCALAR|ARRAYREF,
optional => 1,
},
+ correspondent => {type => SCALAR|ARRAYREF,
+ optional => 1,
+ },
function => {type => CODEREF,
optional => 1,
},
Allows filtering bugs on commonly used criteria
+
+
=cut
sub bug_filter {
my %param = validate_with(params => \@_,
- spec => {bug => {type => SCALAR,
- regex => qr/^\d+$/,
- },
- status => {type => HASHREF,
+ spec => {bug => {type => ARRAYREF|SCALAR,
+ optional => 1,
+ },
+ status => {type => HASHREF|ARRAYREF,
optional => 1,
},
seen_merged => {type => HASHREF,
not defined $param{seen_merged}) {
croak "repeat_merged false requires seen_merged to be passed";
}
+ if (not exists $param{bug} and not exists $param{status}) {
+ croak "one of bug or status must be passed";
+ }
if (not exists $param{status}) {
my $location = getbuglocation($param{bug}, 'summary');
bugs => {type => SCALAR|ARRAYREF,
optional => 1,
},
+ correspondent => {type => SCALAR|ARRAYREF,
+ optional => 1,
+ },
usertags => {type => HASHREF,
optional => 1,
},
tag => {type => SCALAR|ARRAYREF,
optional => 1,
},
+ owner => {type => SCALAR|ARRAYREF,
+ optional => 1,
+ },
+ correspondent => {type => SCALAR|ARRAYREF,
+ optional => 1,
+ },
# not yet supported
-# owner => {type => SCALAR|ARRAYREF,
-# optional => 1,
-# },
# dist => {type => SCALAR|ARRAYREF,
# optional => 1,
# },
delete @param{qw(maint src)};
$param{package} = [@packages];
}
+ my $grep_bugs = 0;
+ my %bugs;
+ if (exists $param{bugs}) {
+ $bugs{$_} = 1 for make_list($param{bugs});
+ $grep_bugs = 1;
+ }
+ if (exists $param{owner} or exists $param{correspondent}) {
+ $bugs{$_} = 1 for get_bugs_by_idx(exists $param{correspondent}?(correspondent => $param{correspondent}):(),
+ exists $param{owner}?(owner => $param{owner}):(),
+ );
+ $grep_bugs = 1;
+ }
my @bugs;
while (<$flatfile>) {
next unless m/^(\S+)\s+(\d+)\s+(\d+)\s+(\S+)\s+\[\s*([^]]*)\s*\]\s+(\w+)\s+(.*)$/;
my ($pkg,$bug,$time,$status,$submitter,$severity,$tags) = ($1,$2,$3,$4,$5,$6,$7);
- next if exists $param{bugs} and not grep {$bug == $_} make_list($param{bugs});
+ next if $grep_bugs and not exists $bugs{$bug};
if (exists $param{package}) {
my @packages = splitpackages($pkg);
next unless grep { my $pkg_list = $_;
},
'severity' => \&__exact_field_match,
'pending' => \&__exact_field_match,
+ 'package' => \&__exact_field_match,
'originator' => \&__contains_field_match,
'forwarded' => \&__contains_field_match,
'owner' => \&__contains_field_match,
use base qw(Exporter);
use Debbugs::URI;
use HTML::Entities;
-use Debbugs::Common qw(getparsedaddrs);
+use Debbugs::Common qw(getparsedaddrs make_list);
use Params::Validate qw(validate_with :types);
use Debbugs::Config qw(:config);
use Debbugs::Status qw(splitpackages isstrongseverity);
use POSIX qw(ceil);
use Storable qw(dclone);
+use List::Util qw(max);
+
+use Carp;
+
+use Debbugs::Text qw(fill_in_template);
+
our %URL_PARAMS = ();
@EXPORT = ();
%EXPORT_TAGS = (url => [qw(bug_url bug_links bug_linklist maybelink),
qw(set_url_params pkg_url version_url),
- qw(submitterurl mainturl munge_url)
+ qw(submitterurl mainturl munge_url),
+ qw(package_links bug_links),
],
html => [qw(html_escape htmlize_bugs htmlize_packagelinks),
qw(maybelink htmlize_addresslinks htmlize_maintlinks),
],
util => [qw(cgi_parameters quitcgi),
],
+ forms => [qw(option_form form_options_and_normal_param)],
misc => [qw(maint_decode)],
+ package_search => [qw(@package_search_key_order %package_search_keys)],
#status => [qw(getbugstatus)],
);
@EXPORT_OK = ();
- Exporter::export_ok_tags(qw(url html util misc));
+ Exporter::export_ok_tags(keys %EXPORT_TAGS);
$EXPORT_TAGS{all} = [@EXPORT_OK];
}
else {
%params = @_;
}
+ carp "bug_url is deprecated, use bug_links instead";
+
return munge_url('bugreport.cgi?',%params,bug=>$ref);
}
else {
%params = @_;
}
+ carp "pkg_url is deprecated, use package_links instead";
return munge_url('pkgreport.cgi?',%params);
}
=head2 version_url
- version_url($package,$found,$fixed)
+ version_url(package => $package,found => $found,fixed => $fixed)
Creates a link to the version cgi script
+=over
+
+=item package -- source package whose graph to display
+
+=item found -- arrayref of found versions
+
+=item fixed -- arrayref of fixed versions
+
+=item width -- optional width of graph
+
+=item height -- optional height of graph
+
+=item info -- display html info surrounding graph; defaults to 1 if
+width and height are not passed.
+
+=item collapse -- whether to collapse the graph; defaults to 1 if
+width and height are passed.
+
+=back
+
=cut
sub version_url{
- my ($package,$found,$fixed,$width,$height) = @_;
+ my %params = validate_with(params => \@_,
+ spec => {package => {type => SCALAR,
+ },
+ found => {type => ARRAYREF,
+ default => [],
+ },
+ fixed => {type => ARRAYREF,
+ default => [],
+ },
+ width => {type => SCALAR,
+ optional => 1,
+ },
+ height => {type => SCALAR,
+ optional => 1,
+ },
+ absolute => {type => BOOLEAN,
+ default => 0,
+ },
+ collapse => {type => BOOLEAN,
+ default => 1,
+ },
+ info => {type => BOOLEAN,
+ optional => 1,
+ },
+ }
+ );
+ if (not defined $params{width} and not defined $params{height}) {
+ $params{info} = 1 if not exists $params{info};
+ }
my $url = Debbugs::URI->new('version.cgi?');
- $url->query_form(package => $package,
- found => $found,
- fixed => $fixed,
- (defined $width)?(width => $width):(),
- (defined $height)?(height => $height):(),
- (defined $width or defined $height)?(collapse => 1):(info => 1),
- );
+ $url->query_form(%params);
return $url->as_string;
}
sub quitcgi {
my $msg = shift;
print "Content-Type: text/html\n\n";
- print "<HTML><HEAD><TITLE>Error</TITLE></HEAD><BODY>\n";
- print "An error occurred. Dammit.\n";
- print "Error was: $msg.\n";
- print "</BODY></HTML>\n";
+ print fill_in_template(template=>'cgi/quit',
+ variables => {msg => $msg}
+ );
exit 0;
}
=head HTML
-=head2 htmlize_bugs
+=head2 htmlize_packagelinks
- htmlize_bugs({bug=>1,status=>\%status,extravars=>\%extra},{bug=>...}});
+ htmlize_packagelinks
-Turns a list of bugs into an html snippit of the bugs.
+Given a scalar containing a list of packages separated by something
+that L<Debbugs::CGI/splitpackages> can separate, returns a
+formatted set of links to packages in html.
=cut
-# htmlize_bugs(bugs=>[@bugs]);
-sub htmlize_bugs{
- my @bugs = @_;
- my @html;
-
- for my $bug (@bugs) {
- my $html = sprintf "<li><a href=\"%s\">#%d: %s</a>\n<br>",
- bug_url($bug->{bug}), $bug->{bug}, html_escape($bug->{status}{subject});
- $html .= htmlize_bugstatus($bug->{status}) . "\n";
- }
- return @html;
+
+sub htmlize_packagelinks {
+ my ($pkgs) = @_;
+ return '' unless defined $pkgs and $pkgs ne '';
+ my @pkglist = splitpackages($pkgs);
+
+ carp "htmlize_packagelinks is deprecated, use package_links instead";
+
+ return 'Package' . (@pkglist > 1 ? 's' : '') . ': ' .
+ package_links(package =>\@pkglist,
+ class => 'submitter'
+ );
}
+=head2 package_links
-sub htmlize_bugstatus {
- my %status = %{$_[0]};
+ join(', ', package_links(packages => \@packages))
- my $result = "";
+Given a list of packages, return a list of html which links to the package
- my $showseverity;
- if ($status{severity} eq $config{default_severity}) {
- $showseverity = '';
- } elsif (isstrongseverity($status{severity})) {
- $showseverity = "Severity: <em class=\"severity\">$status{severity}</em>;\n";
- } else {
- $showseverity = "Severity: <em>$status{severity}</em>;\n";
- }
+=over
+
+=item package -- arrayref or scalar of package(s)
+
+=item submitter -- arrayref or scalar of submitter(s)
+
+=item src -- arrayref or scalar of source(s)
+
+=item maintainer -- arrayref or scalar of maintainer(s)
+
+=item links_only -- return only links, not htmlized links, defaults to
+returning htmlized links.
+
+=item class -- class of the a href, defaults to ''
+
+=back
- $result .= htmlize_packagelinks($status{"package"}, 1);
+=cut
- my $showversions = '';
- if (@{$status{found_versions}}) {
- my @found = @{$status{found_versions}};
- local $_;
- s{/}{ } foreach @found;
- $showversions .= join ', ', map html_escape($_), @found;
+our @package_search_key_order = (package => 'in package',
+ tag => 'tagged',
+ severity => 'with severity',
+ src => 'in source package',
+ maint => 'in packages maintained by',
+ submitter => 'submitted by',
+ owner => 'owned by',
+ status => 'with status',
+ correspondent => 'with mail from',
+ newest => 'newest bugs',
+ );
+our %package_search_keys = @package_search_key_order;
+
+
+sub package_links {
+ my %param = validate_with(params => \@_,
+ spec => {(map { ($_,{type => SCALAR|ARRAYREF,
+ optional => 1,
+ });
+ } keys %package_search_keys,
+ ),
+ links_only => {type => BOOLEAN,
+ default => 0,
+ },
+ class => {type => SCALAR,
+ default => '',
+ },
+ separator => {type => SCALAR,
+ default => ', ',
+ },
+ options => {type => HASHREF,
+ default => {},
+ },
+ },
+ normalize_keys =>
+ sub {
+ my ($key) = @_;
+ my %map = (source => 'src',
+ maintainer => 'maint',
+ pkg => 'package',
+ );
+ return $map{$key} if exists $map{$key};
+ return $key;
+ }
+ );
+ my %options = %{$param{options}};
+ for ((keys %package_search_keys,qw(msg att))) {
+ delete $options{$_} if exists $options{$_};
}
- if (@{$status{fixed_versions}}) {
- $showversions .= '; ' if length $showversions;
- $showversions .= '<strong>fixed</strong>: ';
- my @fixed = @{$status{fixed_versions}};
- $showversions .= join ', ', map {s#/##; html_escape($_)} @fixed;
+ my @links = ();
+ for my $type (qw(src package)) {
+ push @links, map {(munge_url('pkgreport.cgi?',
+ %options,
+ $type => $_,
+ ),
+ $_);
+ } make_list($param{$type}) if exists $param{$type};
}
- $result .= " ($showversions)" if length $showversions;
- $result .= ";\n";
-
- $result .= $showseverity;
- $result .= htmlize_addresslinks("Reported by: ", \&submitterurl,
- $status{originator});
- $result .= ";\nOwned by: " . html_escape($status{owner})
- if length $status{owner};
- $result .= ";\nTags: <strong>"
- . html_escape(join(", ", sort(split(/\s+/, $status{tags}))))
- . "</strong>"
- if (length($status{tags}));
-
- $result .= ";\nMerged with ".
- bug_linklist(', ',
- 'submitter',
- split(/ /,$status{mergedwith}))
- if length $status{mergedwith};
- $result .= ";\nBlocked by ".
- bug_linklist(", ",
- 'submitter',
- split(/ /,$status{blockedby}))
- if length $status{blockedby};
- $result .= ";\nBlocks ".
- bug_linklist(", ",
- 'submitter',
- split(/ /,$status{blocks})
- )
- if length $status{blocks};
-
- my $days = 0;
- if (length($status{done})) {
- $result .= "<br><strong>Done:</strong> " . html_escape($status{done});
- $days = ceil($debbugs::gRemoveAge - -M buglog($status{id}));
- if ($days >= 0) {
- $result .= ";\n<strong>Will be archived" . ( $days == 0 ? " today" : $days == 1 ? " in $days day" : " in $days days" ) . "</strong>";
- } else {
- $result .= ";\n<strong>Archived</strong>";
+ for my $type (qw(maint owner submitter correspondent)) {
+ push @links, map {my $addr = getparsedaddrs($_);
+ $addr = defined $addr?$addr->address:'';
+ (munge_url('pkgreport.cgi?',
+ %options,
+ $type => $addr,
+ ),
+ $_);
+ } make_list($param{$type}) if exists $param{$type};
+ }
+ my @return = ();
+ my ($link,$link_name);
+ my $class = '';
+ if (length $param{class}) {
+ $class = q( class=").html_escape($param{class}).q(");
+ }
+ while (($link,$link_name) = splice(@links,0,2)) {
+ if ($param{links_only}) {
+ push @return,$link
+ }
+ else {
+ push @return,
+ qq(<a$class href=").
+ html_escape($link).q(">).
+ html_escape($link_name).q(</a>);
}
}
+ if (wantarray) {
+ return @return;
+ }
else {
- 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";
- }
- }
+ return join($param{separator},@return);
+ }
+}
- $result .= ".";
+=head2 bug_links
- return $result;
-}
+ join(', ', bug_links(bug => \@packages))
-=head2 htmlize_packagelinks
+Given a list of bugs, return a list of html which links to the bugs
- htmlize_packagelinks
+=over
-Given a scalar containing a list of packages separated by something
-that L<Debbugs::CGI/splitpackages> can separate, returns a
-formatted set of links to packages.
+=item bug -- arrayref or scalar of bug(s)
-=cut
+=item links_only -- return only links, not htmlized links, defaults to
+returning htmlized links.
-sub htmlize_packagelinks {
- my ($pkgs,$strong) = @_;
- return unless defined $pkgs and $pkgs ne '';
- my @pkglist = splitpackages($pkgs);
+=item class -- class of the a href, defaults to ''
- $strong = 0;
- my $openstrong = $strong ? '<strong>' : '';
- my $closestrong = $strong ? '</strong>' : '';
+=back
- return 'Package' . (@pkglist > 1 ? 's' : '') . ': ' .
- join(', ',
- map {
- '<a class="submitter" href="' . pkg_url(pkg=>$_||'') . '">' .
- $openstrong . html_escape($_) . $closestrong . '</a>'
- } @pkglist
- );
+=cut
+
+sub bug_links {
+ my %param = validate_with(params => \@_,
+ spec => {bug => {type => SCALAR|ARRAYREF,
+ optional => 1,
+ },
+ links_only => {type => BOOLEAN,
+ default => 0,
+ },
+ class => {type => SCALAR,
+ default => '',
+ },
+ separator => {type => SCALAR,
+ default => ', ',
+ },
+ options => {type => HASHREF,
+ default => {},
+ },
+ },
+ );
+ my %options = %{$param{options}};
+
+ for (qw(bug)) {
+ delete $options{$_} if exists $options{$_};
+ }
+ my @links;
+ push @links, map {(munge_url('bugreport.cgi?',
+ %options,
+ bug => $_,
+ ),
+ $_);
+ } make_list($param{bug}) if exists $param{bug};
+ my @return;
+ my ($link,$link_name);
+ my $class = '';
+ if (length $param{class}) {
+ $class = q( class=").html_escape($param{class}).q(");
+ }
+ while (($link,$link_name) = splice(@links,0,2)) {
+ if ($param{links_only}) {
+ push @return,$link
+ }
+ else {
+ push @return,
+ qq(<a$class href=").
+ html_escape($link).q(">).
+ html_escape($link_name).q(</a>);
+ }
+ }
+ if (wantarray) {
+ return @return;
+ }
+ else {
+ return join($param{separator},@return);
+ }
}
+
=head2 maybelink
maybelink($in);
sub htmlize_addresslinks {
my ($prefixfunc, $urlfunc, $addresses,$class) = @_;
+ carp "htmlize_addresslinks is deprecated";
+
$class = defined $class?qq(class="$class" ):'';
if (defined $addresses and $addresses ne '') {
my @addrs = getparsedaddrs($addresses);
return $addr;
}
-sub mainturl { pkg_url(maint => emailfromrfc822($_[0])); }
-sub submitterurl { pkg_url(submitter => emailfromrfc822($_[0])); }
+sub mainturl { package_links(maint => $_[0], links_only => 1); }
+sub submitterurl { package_links(submitter => $_[0], links_only => 1); }
sub htmlize_maintlinks {
my ($prefixfunc, $maints) = @_;
+ carp "htmlize_maintlinks is deprecated";
return htmlize_addresslinks($prefixfunc, \&mainturl, $maints);
}
our $_maintainer;
our $_maintainer_rev;
-=head2 bug_links
-
- bug_links($one_bug);
- bug_links($starting_bug,$stoping_bugs,);
-
-Creates a set of links to bugs, starting with bug number
-$starting_bug, and finishing with $stoping_bug; if only one bug is
-passed, makes a link to only a single bug.
-
-The content of the link is the bug number.
-
-XXX Use L<Params::Validate>; we want to be able to support query
-arguments here too.
-
-=cut
-
-sub bug_links{
- my ($start,$stop,$query_arguments) = @_;
- $stop = $stop || $start;
- $query_arguments ||= '';
- my @output;
- for my $bug ($start..$stop) {
- push @output,'<a href="'.bug_url($bug,'').qq(">$bug</a>);
- }
- return join(', ',@output);
-}
-
=head2 bug_linklist
bug_linklist($separator,$class,@bugs)
sub bug_linklist{
my ($sep,$class,@bugs) = @_;
- if (length $class) {
- $class = qq(class="$class" );
+ carp "bug_linklist is deprecated; use bug_links instead";
+ return scalar bug_links(bug=>\@bugs,class=>$class,separator=>$sep);
+}
+
+
+
+=head1 Forms
+
+=cut
+
+=head2 form_options_and_normal_param
+
+ my ($form_option,$param) = form_options_and_normal_param(\%param)
+ if $param{form_options};
+ my $form_option = form_options_and_normal_param(\%param)
+ if $param{form_options};
+
+Translates from special form_options to a set of parameters which can
+be used to run the current page.
+
+The idea behind this is to allow complex forms to relatively easily
+cause options that the existing cgi scripts understand to be set.
+
+Currently there are two commands which are understood:
+combine, and concatenate.
+
+=head3 combine
+
+Combine works by entering key,value pairs into the parameters using
+the key field option input field, and the value field option input
+field.
+
+For example, you would have
+
+ <input type="hidden" name="_fo_combine_key_fo_searchkey_value_fo_searchvalue" value="1">
+
+which would combine the _fo_searchkey and _fo_searchvalue input fields, so
+
+ <input type="text" name="_fo_searchkey" value="foo">
+ <input type="text" name="_fo_searchvalue" value="bar">
+
+would yield foo=>'bar' in %param.
+
+=head3 concatenate
+
+Concatenate concatenates values into a single entry in a parameter
+
+For example, you would have
+
+ <input type="hidden" name="_fo_concatentate_into_foo_with_:_fo_blah_fo_bleargh" value="1">
+
+which would combine the _fo_searchkey and _fo_searchvalue input fields, so
+
+ <input type="text" name="_fo_blah" value="bar">
+ <input type="text" name="_fo_bleargh" value="baz">
+
+would yield foo=>'bar:baz' in %param.
+
+
+=cut
+
+my $form_option_leader = '_fo_';
+sub form_options_and_normal_param{
+ my ($orig_param) = @_;
+ # all form_option parameters start with _fo_
+ my ($param,$form_option) = ({},{});
+ for my $key (keys %{$orig_param}) {
+ if ($key =~ /^\Q$form_option_leader\E/) {
+ $form_option->{$key} = $orig_param->{$key};
+ }
+ else {
+ $param->{$key} = $orig_param->{$key};
+ }
}
- return join($sep,map{qq(<a ${class}href=").
- bug_url($_).qq(">#$_</a>)
- } @bugs);
+ # at this point, we check for commands
+ COMMAND: for my $key (keys %{$form_option}) {
+ $key =~ s/^\Q$form_option_leader\E//;
+ if (my ($key_name,$value_name) =
+ $key =~ /combine_key(\Q$form_option_leader\E.+)
+ _value(\Q$form_option_leader\E.+)$/x
+ ) {
+ next unless defined $form_option->{$key_name};
+ next unless defined $form_option->{$value_name};
+ my @keys = make_list($form_option->{$key_name});
+ my @values = make_list($form_option->{$value_name});
+ for my $i (0 .. $#keys) {
+ last if $i > $#values;
+ next if not defined $keys[$i];
+ next if not defined $values[$i];
+ __add_to_param($param,
+ $keys[$i],
+ $values[$i],
+ );
+ }
+ }
+ elsif (my ($field,$concatenate_key,$fields) =
+ $key =~ /concatenate_into_(.+?)((?:_with_[^_])?)
+ ((?:\Q$form_option_leader\E.+?)+)
+ $/x
+ ) {
+ if (length $concatenate_key) {
+ $concatenate_key =~ s/_with_//;
+ }
+ else {
+ $concatenate_key = ':';
+ }
+ my @fields = $fields =~ m/(\Q$form_option_leader\E.+?)(?:(?=\Q$form_option_leader\E)|$)/g;
+ my %field_list;
+ my $max_num = 0;
+ for my $f (@fields) {
+ next COMMAND unless defined $form_option->{$f};
+ $field_list{$f} = [make_list($form_option->{$f})];
+ $max_num = max($max_num,$#{$field_list{$f}});
+ }
+ for my $i (0 .. $max_num) {
+ next unless @fields == grep {$i <= $#{$field_list{$_}} and
+ defined $field_list{$_}[$i]} @fields;
+ __add_to_param($param,
+ $field,
+ join($concatenate_key,
+ map {$field_list{$_}[$i]} @fields
+ )
+ );
+ }
+ }
+ }
+ return wantarray?($form_option,$param):$form_option;
}
+=head2 option_form
+
+ print option_form(template=>'pkgreport_options',
+ param => \%param,
+ form_options => $form_options,
+ )
+
+
+
+=cut
+
+sub option_form{
+ my %param = validate_with(params => \@_,
+ spec => {template => {type => SCALAR,
+ },
+ variables => {type => HASHREF,
+ default => {},
+ },
+ language => {type => SCALAR,
+ optional => 1,
+ },
+ param => {type => HASHREF,
+ default => {},
+ },
+ form_options => {type => HASHREF,
+ default => {},
+ },
+ },
+ );
+
+ # First, we need to see if we need to add particular types of
+ # parameters
+ my $variables = dclone($param{variables});
+ $variables->{param} = dclone($param{param});
+ 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
+ __add_to_param($variables->{param},
+ $1,
+ ''
+ );
+ }
+ elsif ($key =~ /^delete_(.+?)(?:_(\d+))?$/) {
+ next unless exists $variables->{param}{$1};
+ if (ref $variables->{param}{$1} eq 'ARRAY' and
+ defined $2 and
+ defined $variables->{param}{$1}[$2]
+ ) {
+ splice @{$variables->{param}{$1}},$2,1;
+ }
+ else {
+ delete $variables->{param}{$1};
+ }
+ }
+ # we'll add extra comands here once I figure out what they
+ # should be
+ }
+ # add in a few utility routines
+ $variables->{output_select_options} = sub {
+ my ($options,$value) = @_;
+ my @options = @{$options};
+ my $output = '';
+ while (my ($o_value,$name) = splice @options,0,2) {
+ my $selected = '';
+ if (defined $value and $o_value eq $value) {
+ $selected = ' selected';
+ }
+ $output .= qq(<option value="$o_value"$selected>$name</option>\n);
+ }
+ return $output;
+ };
+ $variables->{make_list} = sub { make_list(@_);
+ };
+ # now at this point, we're ready to create the template
+ return Debbugs::Text::fill_in_template(template=>$param{template},
+ (exists $param{language}?(language=>$param{language}):()),
+ variables => $variables,
+ );
+}
+
+sub __add_to_param{
+ my ($param,$key,@values) = @_;
+
+ if (exists $param->{$key} and not
+ ref $param->{$key}) {
+ @{$param->{$key}} = [$param->{$key},
+ @values
+ ];
+ }
+ else {
+ push @{$param->{$key}}, @values;
+ }
+}
+
+
=head1 misc
--- /dev/null
+# This module is part of debbugs, and is released
+# under the terms of the GPL version 2, or any later version. See the
+# file README and COPYING for more information.
+#
+# [Other people have contributed to this file; their copyrights should
+# be listed here too.]
+# Copyright 2008 by Don Armstrong <don@donarmstrong.com>.
+
+
+package Debbugs::CGI::Bugreport;
+
+=head1 NAME
+
+Debbugs::CGI::Bugreport -- specific routines for the bugreport cgi script
+
+=head1 SYNOPSIS
+
+
+=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);
+
+use IO::Scalar;
+use Params::Validate qw(validate_with :types);
+use Debbugs::MIME qw(convert_to_utf8 decode_rfc1522 create_mime_message);
+use Debbugs::CGI qw(:url :html :util);
+use Debbugs::Common qw(globify_scalar);
+use POSIX qw(strftime);
+
+BEGIN{
+ ($VERSION) = q$Revision: 494 $ =~ /^Revision:\s+([^\s+])/;
+ $DEBUG = 0 unless defined $DEBUG;
+
+ @EXPORT = ();
+ %EXPORT_TAGS = ();
+ @EXPORT_OK = (qw(display_entities handle_record handle_email_message));
+ Exporter::export_ok_tags(keys %EXPORT_TAGS);
+ $EXPORT_TAGS{all} = [@EXPORT_OK];
+}
+
+
+
+=head2 display_entity
+
+ display_entity(entity => $entity,
+ bug_num => $ref,
+ outer => 1,
+ msg_num => $msg_num,
+ attachments => \@attachments,
+ output => \$output);
+
+
+=over
+
+=item entity -- MIME::Parser entity
+
+=item bug_num -- Bug number
+
+=item outer -- Whether this is the outer entity; defaults to 1
+
+=item msg_num -- message number in the log
+
+=item attachments -- arrayref of attachments
+
+=item output -- scalar reference for output
+
+=back
+
+=cut
+
+sub display_entity {
+ my %param = validate_with(params => \@_,
+ spec => {entity => {type => OBJECT,
+ },
+ bug_num => {type => SCALAR,
+ regex => qr/^\d+$/,
+ },
+ outer => {type => BOOLEAN,
+ default => 1,
+ },
+ msg_num => {type => SCALAR,
+ },
+ attachments => {type => ARRAYREF,
+ default => [],
+ },
+ output => {type => SCALARREF|HANDLE,
+ default => \*STDOUT,
+ },
+ terse => {type => BOOLEAN,
+ default => 0,
+ },
+ msg => {type => SCALAR,
+ optional => 1,
+ },
+ att => {type => SCALAR,
+ optional => 1,
+ },
+ trim_headers => {type => BOOLEAN,
+ default => 1,
+ },
+ }
+ );
+
+ $param{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 $head = $entity->head;
+ my $disposition = $head->mime_attr('content-disposition');
+ $disposition = 'inline' if not defined $disposition or $disposition eq '';
+ my $type = $entity->effective_type;
+ my $filename = $entity->head->recommended_filename;
+ $filename = '' unless defined $filename;
+ $filename = decode_rfc1522($filename);
+
+ if ($param{outer} and
+ not $param{terse} and
+ not exists $param{att}) {
+ my $header = $entity->head;
+ print {$param{output}} "<pre class=\"headers\">\n";
+ if ($param{trim_headers}) {
+ my @headers;
+ foreach (qw(From To Cc Subject Date)) {
+ my $head_field = $head->get($_);
+ next unless defined $head_field and $head_field ne '';
+ push @headers, qq(<b>$_:</b> ) . html_escape(decode_rfc1522($head_field));
+ }
+ print {$param{output}} join(qq(), @headers);
+ } else {
+ print {$param{output}} html_escape(decode_rfc1522($entity->head->stringify));
+ }
+ print {$param{output}} "</pre>\n";
+ }
+
+ if (not (($param{outer} and $type =~ m{^text(?:/plain)?(?:;|$)})
+ or $type =~ m{^multipart/}
+ )) {
+ push @$attachments, $param{entity};
+ # output this attachment
+ if (exists $param{att} and
+ $param{att} == $#$attachments) {
+ my $head = $entity->head;
+ chomp(my $type = $entity->effective_type);
+ my $body = $entity->stringify_body;
+ print {$param{output}} "Content-Type: $type";
+ my ($charset) = $head->get('Content-Type:') =~ m/charset\s*=\s*\"?([\w-]+)\"?/i;
+ print {$param{output}} qq(; charset="$charset") if defined $charset;
+ print {$param{output}}"\n";
+ if ($filename ne '') {
+ my $qf = $filename;
+ $qf =~ s/"/\\"/g;
+ $qf =~ s[.*/][];
+ print {$param{output}} qq{Content-Disposition: inline; filename="$qf"\n};
+ }
+ print {$param{output}} "\n";
+ my $decoder = MIME::Decoder->new($head->mime_encoding);
+ $decoder->decode(IO::Scalar->new(\$body), $param{output});
+ return;
+ }
+ elsif (not exists $param{att}) {
+ my @dlargs = (msg=>$xmessage, att=>$#$attachments);
+ push @dlargs, (filename=>$filename) if $filename ne '';
+ my $printname = $filename;
+ $printname = 'Message part ' . ($#$attachments + 1) if $filename eq '';
+ print {$param{output}} '<pre class="mime">[<a href="' .
+ html_escape(bug_links(bug => $ref,
+ links_only => 1,
+ options => {@dlargs})
+ ) . qq{">$printname</a> } .
+ "($type, $disposition)]</pre>\n";
+ }
+ }
+
+ return if not $param{outer} and $disposition eq 'attachment' and not exists $param{att};
+ return unless ($type =~ m[^text/?] and
+ $type !~ m[^text/(?:html|enriched)(?:;|$)]) or
+ $type =~ m[^application/pgp(?:;|$)] or
+ $entity->parts;
+
+ if ($entity->is_multipart) {
+ my @parts = $entity->parts;
+ foreach my $part (@parts) {
+ display_entity(entity => $part,
+ bug_num => $ref,
+ outer => 0,
+ msg_num => $xmessage,
+ output => $param{output},
+ attachments => $attachments,
+ terse => $param{terse},
+ exists $param{msg}?(msg=>$param{msg}):(),
+ exists $param{att}?(att=>$param{att}):(),
+ );
+ # print {$param{output}} "\n";
+ }
+ } elsif ($entity->parts) {
+ # We must be dealing with a nested message.
+ if (not exists $param{att}) {
+ print {$param{output}} "<blockquote>\n";
+ }
+ my @parts = $entity->parts;
+ foreach my $part (@parts) {
+ display_entity(entity => $part,
+ bug_num => $ref,
+ outer => 1,
+ msg_num => $xmessage,
+ ouput => $param{output},
+ attachments => $attachments,
+ terse => $param{terse},
+ exists $param{msg}?(msg=>$param{msg}):(),
+ exists $param{att}?(att=>$param{att}):(),
+ );
+ # print {$param{output}} "\n";
+ }
+ if (not exists $param{att}) {
+ print {$param{output}} "</blockquote>\n";
+ }
+ } elsif (not $param{terse}) {
+ my $content_type = $entity->head->get('Content-Type:') || "text/html";
+ my ($charset) = $content_type =~ m/charset\s*=\s*\"?([\w-]+)\"?/i;
+ my $body = $entity->bodyhandle->as_string;
+ $body = convert_to_utf8($body,$charset) if defined $charset;
+ $body = html_escape($body);
+ # 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.
+ }
+ # Add links to URLs
+ # We don't html escape here because we escape above;
+ # wierd terminators are because of that
+ $body =~ s{((?:ftp|http|https|svn|ftps|rsync)://[\S~-]+?/?) # Url
+ ((?:\>\;)?[)]?(?:'|\&\#39\;)?[:.\,]?(?:\s|$)) # terminators
+ }{<a href=\"$1\">$1</a>$2}gox;
+ # Add links to bug closures
+ $body =~ s[(closes:\s*(?:bug)?\#?\s?\d+(?:,?\s*(?:bug)?\#?\s?\d+)*)]
+ [my $temp = $1;
+ $temp =~ s{(\d+)}
+ {bug_links(bug=>$1)}ge;
+ $temp;]gxie;
+
+ if (not exists $param{att}) {
+ print {$param{output}} qq(<pre class="message">$body</pre>\n);
+ }
+ }
+}
+
+
+=head2 handle_email_message
+
+ handle_email_message($record->{text},
+ ref => $bug_number,
+ msg_num => $msg_number,
+ );
+
+Returns a decoded e-mail message and displays entities/attachments as
+appropriate.
+
+
+=cut
+
+sub handle_email_message{
+ my ($email,%param) = @_;
+
+ my $output = '';
+ my $parser = MIME::Parser->new();
+ # Because we are using memory, not tempfiles, there's no need to
+ # clean up here like in Debbugs::MIME
+ $parser->tmp_to_core(1);
+ $parser->output_to_core(1);
+ my $entity = $parser->parse_data( $email);
+ my @attachments = ();
+ display_entity(entity => $entity,
+ bug_num => $param{ref},
+ outer => 1,
+ msg_num => $param{msg_num},
+ output => \$output,
+ attachments => \@attachments,
+ terse => $param{terse},
+ exists $param{msg}?(msg=>$param{msg}):(),
+ exists $param{att}?(att=>$param{att}):(),
+ );
+ return $output;
+
+}
+
+=head2 handle_record
+
+ push @log, handle_record($record,$ref,$msg_num);
+
+Deals with a record in a bug log as returned by
+L<Debbugs::Log::read_log_records>; returns the log information that
+should be output to the browser.
+
+=cut
+
+sub handle_record{
+ my ($record,$bug_number,$msg_number,$seen_msg_ids) = @_;
+
+ my $output = '';
+ local $_ = $record->{type};
+ if (/html/) {
+ my ($time) = $record->{text} =~ /<!--\s+time:(\d+)\s+-->/;
+ my $class = $record->{text} =~ /^<strong>(?:Acknowledgement|Reply|Information|Report|Notification)/ ? 'infmessage':'msgreceived';
+ $output .= decode_rfc1522($record->{text});
+ # Link to forwarded http:// urls in the midst of the report
+ # (even though these links already exist at the top)
+ $output =~ s,((?:ftp|http|https)://[\S~-]+?/?)([\)\'\:\.\,]?(?:\s|\.<|$)),<a href=\"$1\">$1</a>$2,go;
+ # Add links to the cloned bugs
+ $output =~ s{(Bug )(\d+)( cloned as bugs? )(\d+)(?:\-(\d+)|)}{$1.bug_links(bug=>$2).$3.bug_links(bug=>[$4..$5])}eo;
+ # Add links to merged bugs
+ $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.
+ join(' ',map {bug_links(bug=>$_)} (split /\,?\s+/, $4))}eo;
+ # Add links to reassigned packages
+ $output =~ s{(Bug reassigned from package \`)([^']+?)((?:'|\&\#39;) to \`)([^']+?)((?:'|\&\#39;))}
+ {$1.q(<a href=").html_escape(pkg_url(pkg=>$2)).qq(">$2</a>).$3.q(<a href=").html_escape(pkg_url(pkg=>$4)).qq(">$4</a>).$5}eo;
+ if (defined $time) {
+ $output .= ' ('.strftime('%a, %d %b %Y %T GMT',gmtime($time)).') ';
+ }
+ $output .= '<a href="' .
+ html_escape(bug_links(bug => $bug_number,
+ options => {msg => ($msg_number+1)},
+ links_only => 1,
+ )
+ ) . '">Full text</a> and <a href="' .
+ html_escape(bug_links(bug => $bug_number,
+ options => {msg => ($msg_number+1),
+ mbox => 'yes'},
+ links_only => 1)
+ ) . '">rfc822 format</a> available.';
+
+ $output = qq(<div class="$class"><hr>\n<a name="$msg_number"></a>\n) . $output . "</div>\n";
+ }
+ elsif (/recips/) {
+ my ($msg_id) = $record->{text} =~ /^Message-Id:\s+<(.+)>/im;
+ if (defined $msg_id and exists $$seen_msg_ids{$msg_id}) {
+ return ();
+ }
+ elsif (defined $msg_id) {
+ $$seen_msg_ids{$msg_id} = 1;
+ }
+ $output .= qq(<hr><p class="msgreceived"><a name="$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->{text},
+ ref => $bug_number,
+ msg_num => $msg_number,
+ );
+ }
+ elsif (/autocheck/) {
+ # Do nothing
+ }
+ elsif (/incoming-recv/) {
+ my ($msg_id) = $record->{text} =~ /^Message-Id:\s+<(.+)>/im;
+ if (defined $msg_id and exists $$seen_msg_ids{$msg_id}) {
+ return ();
+ }
+ elsif (defined $msg_id) {
+ $$seen_msg_ids{$msg_id} = 1;
+ }
+ # Incomming Mail Message
+ my ($received,$hostname) = $record->{text} =~ m/Received: \(at (\S+)\) by (\S+)\;/;
+ $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 |.
+ html_escape("$received\@$hostname") .
+ q| (<a href="| . html_escape(bug_links(bug => $bug_number, links_only => 1, options => {msg=>$msg_number})) . '">full text</a>'.
+ q|, <a href="| . html_escape(bug_links(bug => $bug_number,
+ links_only => 1,
+ options => {msg=>$msg_number,
+ mbox=>'yes'}
+ )
+ ) .'">mbox</a>)'.":</p>\n";
+ $output .= handle_email_message($record->{text},
+ ref => $bug_number,
+ msg_num => $msg_number,
+ );
+ }
+ else {
+ die "Unknown record type $_";
+ }
+ return $output;
+}
+
+
+
+1;
+
+
+__END__
+
+
+
+
+
+
--- /dev/null
+# This module is part of debbugs, and is released
+# under the terms of the GPL version 2, or any later version. See the
+# file README and COPYING for more information.
+#
+# [Other people have contributed to this file; their copyrights should
+# be listed here too.]
+# Copyright 2008 by Don Armstrong <don@donarmstrong.com>.
+
+
+package Debbugs::CGI::Pkgreport;
+
+=head1 NAME
+
+Debbugs::CGI::Pkgreport -- specific routines for the pkgreport cgi script
+
+=head1 SYNOPSIS
+
+
+=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);
+
+use IO::Scalar;
+use Params::Validate qw(validate_with :types);
+
+use Debbugs::Config qw(:config :globals);
+use Debbugs::CGI qw(:url :html :util);
+use Debbugs::Common qw(:misc :util :date);
+use Debbugs::Status qw(:status);
+use Debbugs::Bugs qw(bug_filter);
+use Debbugs::Packages qw(:mapping);
+
+use Debbugs::Text qw(:templates);
+
+use POSIX qw(strftime);
+
+
+BEGIN{
+ ($VERSION) = q$Revision: 494 $ =~ /^Revision:\s+([^\s+])/;
+ $DEBUG = 0 unless defined $DEBUG;
+
+ @EXPORT = ();
+ %EXPORT_TAGS = (html => [qw(short_bug_status_html pkg_htmlizebugs),
+ qw(pkg_javascript),
+ qw(pkg_htmlselectyesno pkg_htmlselectsuite),
+ qw(buglinklist pkg_htmlselectarch)
+ ],
+ misc => [qw(generate_package_info make_order_list),
+ qw(myurl),
+ qw(get_bug_order_index determine_ordering),
+ ],
+ );
+ @EXPORT_OK = (qw());
+ Exporter::export_ok_tags(keys %EXPORT_TAGS);
+ $EXPORT_TAGS{all} = [@EXPORT_OK];
+}
+
+=head2 generate_package_info
+
+ generate_package_info($srcorbin,$package)
+
+Generates the informational bits for a package and returns it
+
+=cut
+
+sub generate_package_info{
+ my %param = validate_with(params => \@_,
+ spec => {binary => {type => BOOLEAN,
+ default => 1,
+ },
+ package => {type => SCALAR|ARRAYREF,
+ },
+ options => {type => HASHREF,
+ },
+ bugs => {type => ARRAYREF,
+ },
+ },
+ );
+
+ my $output_scalar = '';
+ my $output = globify_scalar(\$output_scalar);
+
+ my $package = $param{package};
+
+ my %pkgsrc = %{getpkgsrc()};
+ my $srcforpkg = $package;
+ if ($param{binary} and exists $pkgsrc{$package}
+ and defined $pkgsrc{$package}) {
+ $srcforpkg = $pkgsrc{$package};
+ }
+
+ my $showpkg = html_escape($package);
+ my $maintainers = getmaintainers();
+ my $maint = $maintainers->{$srcforpkg};
+ if (defined $maint) {
+ print {$output} '<p>';
+ print {$output} (($maint =~ /,/)? "Maintainer for $showpkg is "
+ : "Maintainers for $showpkg are ") .
+ package_links(maint => $maint);
+ print {$output} ".</p>\n";
+ }
+ else {
+ print {$output} "<p>No maintainer for $showpkg. Please do not report new bugs against this package.</p>\n";
+ }
+ my @pkgs = getsrcpkgs($srcforpkg);
+ @pkgs = grep( !/^\Q$package\E$/, @pkgs );
+ if ( @pkgs ) {
+ @pkgs = sort @pkgs;
+ if ($param{binary}) {
+ print {$output} "<p>You may want to refer to the following packages that are part of the same source:\n";
+ }
+ else {
+ print {$output} "<p>You may want to refer to the following individual bug pages:\n";
+ }
+ #push @pkgs, $src if ( $src && !grep(/^\Q$src\E$/, @pkgs) );
+ print {$output} scalar package_links(package=>[@pkgs]);
+ print {$output} ".\n";
+ }
+ my @references;
+ my $pseudodesc = getpseudodesc();
+ if ($package and defined($pseudodesc) and exists($pseudodesc->{$package})) {
+ push @references, "to the <a href=\"http://${debbugs::gWebDomain}/pseudo-packages${debbugs::gHTMLSuffix}\">".
+ "list of other pseudo-packages</a>";
+ }
+ else {
+ if ($package and defined $gPackagePages) {
+ push @references, sprintf "to the <a href=\"%s\">%s package page</a>",
+ html_escape("http://${gPackagePages}/$package"), html_escape("$package");
+ }
+ if (defined $gSubscriptionDomain) {
+ my $ptslink = $param{binary} ? $srcforpkg : $package;
+ push @references, q(to the <a href="http://).html_escape("$gSubscriptionDomain/$ptslink").q(">Package Tracking System</a>);
+ }
+ # Only output this if the source listing is non-trivial.
+ if ($param{binary} and $srcforpkg) {
+ push @references,
+ "to the source package ".
+ package_links(src=>$srcforpkg,
+ options => $param{options}) .
+ "'s bug page";
+ }
+ }
+ if (@references) {
+ $references[$#references] = "or $references[$#references]" if @references > 1;
+ print {$output} "<p>You might like to refer ", join(", ", @references), ".</p>\n";
+ }
+ if (defined $param{maint} || defined $param{maintenc}) {
+ 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://${debbugs::gWebDomain}/Reporting${debbugs::gHTMLSuffix}");
+ }
+ if (not $maint and not @{$param{bugs}}) {
+ print {$output} "<p>There is no record of the " . html_escape($package) .
+ ($param{binary} ? " package" : " source package") .
+ ", and no bugs have been filed against it.</p>";
+ }
+ return $output_scalar;
+}
+
+
+=head2 short_bug_status_html
+
+ print short_bug_status_html(status => read_bug(bug => 5),
+ options => \%param,
+ );
+
+=over
+
+=item status -- status hashref as returned by read_bug
+
+=item options -- hashref of options to pass to package_links (defaults
+to an empty hashref)
+
+=item bug_options -- hashref of options to pass to bug_links (default
+to an empty hashref)
+
+=item snippet -- optional snippet of information about the bug to
+display below
+
+
+=back
+
+
+
+=cut
+
+sub short_bug_status_html {
+ my %param = validate_with(params => \@_,
+ spec => {status => {type => HASHREF,
+ },
+ options => {type => HASHREF,
+ default => {},
+ },
+ bug_options => {type => HASHREF,
+ default => {},
+ },
+ snippet => {type => SCALAR,
+ default => '',
+ },
+ },
+ );
+
+ my %status = %{$param{status}};
+
+ $status{tags_array} = [sort(split(/\s+/, $status{tags}))];
+ $status{date_text} = strftime('%a, %e %b %Y %T UTC', gmtime($status{date}));
+ $status{mergedwith_array} = [split(/ /,$status{mergedwith})];
+
+ my @blockedby= split(/ /, $status{blockedby});
+ $status{blockedby_array} = [];
+ 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};
+ push @{$status{blockedby_array}},{bug_num => $b, subject => $s{subject}, status => \%s};
+ }
+ }
+
+ my @blocks= split(/ /, $status{blocks});
+ $status{blocks_array} = [];
+ if (@blocks && $status{"pending"} ne 'fixed' && ! length($status{done})) {
+ for my $b (@blocks) {
+ my %s = %{get_bug_status($b)};
+ next if $s{"pending"} eq 'fixed' || length $s{done};
+ push @{$status{blocks_array}}, {bug_num => $b, subject => $s{subject}, status => \%s};
+ }
+ }
+
+
+ return fill_in_template(template => 'cgi/short_bug_status',
+ variables => {status => \%status,
+ isstrongseverity => \&Debbugs::Status::isstrongseverity,
+ html_escape => \&Debbugs::CGI::html_escape,
+ looks_like_number => \&Scalar::Util::looks_like_number,
+ },
+ hole_var => {'&package_links' => \&Debbugs::CGI::package_links,
+ '&bug_links' => \&Debbugs::CGI::bug_links,
+ '&version_url' => \&Debbugs::CGI::version_url,
+ '&secs_to_english' => \&Debbugs::Common::secs_to_english,
+ '&strftime' => \&POSIX::strftime,
+ },
+ );
+
+ my $result = "";
+
+ my $showseverity;
+ if ($status{severity} eq 'normal') {
+ $showseverity = '';
+ }
+ elsif (isstrongseverity($status{severity})) {
+ $showseverity = "Severity: <em class=\"severity\">$status{severity}</em>;\n";
+ }
+ else {
+ $showseverity = "Severity: <em>$status{severity}</em>;\n";
+ }
+
+ $result .= package_links(package => $status{package},
+ options => $param{options},
+ );
+
+ my $showversions = '';
+ if (@{$status{found_versions}}) {
+ my @found = @{$status{found_versions}};
+ $showversions .= join ', ', map {s{/}{ }; html_escape($_)} @found;
+ }
+ if (@{$status{fixed_versions}}) {
+ $showversions .= '; ' if length $showversions;
+ $showversions .= '<strong>fixed</strong>: ';
+ my @fixed = @{$status{fixed_versions}};
+ $showversions .= join ', ', map {s{/}{ }; html_escape($_)} @fixed;
+ }
+ $result .= ' (<a href="'.
+ version_url(package => $status{package},
+ found => $status{found_versions},
+ fixed => $status{fixed_versions},
+ ).qq{">$showversions</a>)} if length $showversions;
+ $result .= ";\n";
+
+ $result .= $showseverity;
+ $result .= "Reported by: ".package_links(submitter=>$status{originator},
+ class => "submitter",
+ );
+ $result .= ";\nOwned by: " . package_links(owner => $status{owner},
+ class => "submitter",
+ )
+ if length $status{owner};
+ $result .= ";\nTags: <strong>"
+ . html_escape(join(", ", sort(split(/\s+/, $status{tags}))))
+ . "</strong>"
+ if (length($status{tags}));
+
+ $result .= (length($status{mergedwith})?";\nMerged with ":"") .
+ bug_links(bug => [split(/ /,$status{mergedwith})],
+ class => "submitter",
+ );
+ $result .= (length($status{blockedby})?";\nBlocked by ":"") .
+ bug_links(bug => [split(/ /,$status{blockedby})],
+ class => "submitter",
+ );
+ $result .= (length($status{blocks})?";\nBlocks ":"") .
+ bug_links(bug => [split(/ /,$status{blocks})],
+ class => "submitter",
+ );
+
+ if (length($status{done})) {
+ $result .= "<br><strong>Done:</strong> " . html_escape($status{done});
+ my $days = bug_archiveable(bug => $status{id},
+ status => \%status,
+ days_until => 1,
+ );
+ if ($days >= 0 and defined $status{location} and $status{location} ne 'archive') {
+ $result .= ";\n<strong>Can be archived" . ( $days == 0 ? " today" : $days == 1 ? " in $days day" : " in $days days" ) . "</strong>";
+ }
+ elsif (defined $status{location} and $status{location} eq 'archived') {
+ $result .= ";\n<strong>Archived.</strong>";
+ }
+ }
+
+ unless (length($status{done})) {
+ if (length($status{forwarded})) {
+ $result .= ";\n<strong>Forwarded</strong> to "
+ . join(', ',
+ map {maybelink($_)}
+ split /\,\s+/,$status{forwarded}
+ );
+ }
+ # Check the age of the logfile
+ my ($days_last,$eng_last) = secs_to_english(time - $status{log_modified});
+ my ($days,$eng) = secs_to_english(time - $status{date});
+
+ if ($days >= 7) {
+ my $font = "";
+ my $efont = "";
+ $font = "em" if ($days > 30);
+ $font = "strong" if ($days > 60);
+ $efont = "</$font>" if ($font);
+ $font = "<$font>" if ($font);
+
+ $result .= ";\n ${font}$eng old$efont";
+ }
+ if ($days_last > 7) {
+ my $font = "";
+ my $efont = "";
+ $font = "em" if ($days_last > 30);
+ $font = "strong" if ($days_last > 60);
+ $efont = "</$font>" if ($font);
+ $font = "<$font>" if ($font);
+
+ $result .= ";\n ${font}Modified $eng_last ago$efont";
+ }
+ }
+
+ $result .= ".";
+
+ return $result;
+}
+
+
+sub pkg_htmlizebugs {
+ my %param = validate_with(params => \@_,
+ spec => {bugs => {type => ARRAYREF,
+ },
+ names => {type => ARRAYREF,
+ },
+ title => {type => ARRAYREF,
+ },
+ prior => {type => ARRAYREF,
+ },
+ order => {type => ARRAYREF,
+ },
+ ordering => {type => SCALAR,
+ },
+ bugusertags => {type => HASHREF,
+ default => {},
+ },
+ bug_rev => {type => BOOLEAN,
+ default => 0,
+ },
+ bug_order => {type => SCALAR,
+ },
+ repeatmerged => {type => BOOLEAN,
+ default => 1,
+ },
+ include => {type => ARRAYREF,
+ default => [],
+ },
+ exclude => {type => ARRAYREF,
+ default => [],
+ },
+ this => {type => SCALAR,
+ default => '',
+ },
+ options => {type => HASHREF,
+ default => {},
+ },
+ }
+ );
+ my @bugs = @{$param{bugs}};
+
+ my @status = ();
+ my %count;
+ my $header = '';
+ my $footer = "<h2 class=\"outstanding\">Summary</h2>\n";
+
+ my @dummy = ($gRemoveAge); #, @gSeverityList, @gSeverityDisplay); #, $gHTMLExpireNote);
+
+ if (@bugs == 0) {
+ return "<HR><H2>No reports found!</H2></HR>\n";
+ }
+
+ if ( $param{bug_rev} ) {
+ @bugs = sort {$b<=>$a} @bugs;
+ }
+ else {
+ @bugs = sort {$a<=>$b} @bugs;
+ }
+ my %seenmerged;
+
+ my %common = (
+ 'show_list_header' => 1,
+ 'show_list_footer' => 1,
+ );
+
+ my %section = ();
+ # Make the include/exclude map
+ my %include;
+ my %exclude;
+ for my $include (make_list($param{include})) {
+ next unless defined $include;
+ my ($key,$value) = split /\s*:\s*/,$include,2;
+ unless (defined $value) {
+ $key = 'tags';
+ $value = $include;
+ }
+ push @{$include{$key}}, split /\s*,\s*/, $value;
+ }
+ for my $exclude (make_list($param{exclude})) {
+ next unless defined $exclude;
+ my ($key,$value) = split /\s*:\s*/,$exclude,2;
+ unless (defined $value) {
+ $key = 'tags';
+ $value = $exclude;
+ }
+ push @{$exclude{$key}}, split /\s*,\s*/, $value;
+ }
+
+ foreach my $bug (@bugs) {
+ my %status = %{get_bug_status(bug=>$bug,
+ (exists $param{dist}?(dist => $param{dist}):()),
+ bugusertags => $param{bugusertags},
+ (exists $param{version}?(version => $param{version}):()),
+ (exists $param{arch}?(arch => $param{arch}):(arch => $config{default_architectures})),
+ )};
+ next unless %status;
+ next if bug_filter(bug => $bug,
+ status => \%status,
+ repeat_merged => $param{repeatmerged},
+ seen_merged => \%seenmerged,
+ (keys %include ? (include => \%include):()),
+ (keys %exclude ? (exclude => \%exclude):()),
+ );
+
+ my $html = "<li>"; #<a href=\"%s\">#%d: %s</a>\n<br>",
+ #bug_url($bug), $bug, html_escape($status{subject});
+ $html .= short_bug_status_html(status => \%status,
+ options => $param{options},
+ ) . "\n";
+ push @status, [ $bug, \%status, $html ];
+ }
+ if ($param{bug_order} eq 'age') {
+ # MWHAHAHAHA
+ @status = sort {$a->[1]{log_modified} <=> $b->[1]{log_modified}} @status;
+ }
+ elsif ($param{bug_order} eq 'agerev') {
+ @status = sort {$b->[1]{log_modified} <=> $a->[1]{log_modified}} @status;
+ }
+ for my $entry (@status) {
+ my $key = "";
+ for my $i (0..$#{$param{prior}}) {
+ my $v = get_bug_order_index($param{prior}[$i], $entry->[1]);
+ $count{"g_${i}_${v}"}++;
+ $key .= "_$v";
+ }
+ $section{$key} .= $entry->[2];
+ $count{"_$key"}++;
+ }
+
+ my $result = "";
+ if ($param{ordering} eq "raw") {
+ $result .= "<UL class=\"bugs\">\n" . join("", map( { $_->[ 2 ] } @status ) ) . "</UL>\n";
+ }
+ else {
+ $header .= "<div class=\"msgreceived\">\n<ul>\n";
+ my @keys_in_order = ("");
+ for my $o (@{$param{order}}) {
+ push @keys_in_order, "X";
+ while ((my $k = shift @keys_in_order) ne "X") {
+ for my $k2 (@{$o}) {
+ $k2+=0;
+ push @keys_in_order, "${k}_${k2}";
+ }
+ }
+ }
+ for my $order (@keys_in_order) {
+ next unless defined $section{$order};
+ my @ttl = split /_/, $order;
+ shift @ttl;
+ my $title = $param{title}[0]->[$ttl[0]] . " bugs";
+ if ($#ttl > 0) {
+ $title .= " -- ";
+ $title .= join("; ", grep {($_ || "") ne ""}
+ map { $param{title}[$_]->[$ttl[$_]] } 1..$#ttl);
+ }
+ $title = html_escape($title);
+
+ my $count = $count{"_$order"};
+ my $bugs = $count == 1 ? "bug" : "bugs";
+
+ $header .= "<li><a href=\"#$order\">$title</a> ($count $bugs)</li>\n";
+ if ($common{show_list_header}) {
+ my $count = $count{"_$order"};
+ my $bugs = $count == 1 ? "bug" : "bugs";
+ $result .= "<H2 CLASS=\"outstanding\"><a name=\"$order\"></a>$title ($count $bugs)</H2>\n";
+ }
+ else {
+ $result .= "<H2 CLASS=\"outstanding\">$title</H2>\n";
+ }
+ $result .= "<div class=\"msgreceived\">\n<UL class=\"bugs\">\n";
+ $result .= "\n\n\n\n";
+ $result .= $section{$order};
+ $result .= "\n\n\n\n";
+ $result .= "</UL>\n</div>\n";
+ }
+ $header .= "</ul></div>\n";
+
+ $footer .= "<div class=\"msgreceived\">\n<ul>\n";
+ for my $i (0..$#{$param{prior}}) {
+ my $local_result = '';
+ foreach my $key ( @{$param{order}[$i]} ) {
+ my $count = $count{"g_${i}_$key"};
+ next if !$count or !$param{title}[$i]->[$key];
+ $local_result .= "<li>$count $param{title}[$i]->[$key]</li>\n";
+ }
+ if ( $local_result ) {
+ $footer .= "<li>$param{names}[$i]<ul>\n$local_result</ul></li>\n";
+ }
+ }
+ $footer .= "</ul>\n</div>\n";
+ }
+
+ $result = $header . $result if ( $common{show_list_header} );
+ $result .= $footer if ( $common{show_list_footer} );
+ return $result;
+}
+
+sub pkg_javascript {
+ return fill_in_template(template=>'cgi/pkgreport_javascript',
+ );
+}
+
+sub pkg_htmlselectyesno {
+ my ($name, $n, $y, $default) = @_;
+ return sprintf('<select name="%s"><option value=no%s>%s</option><option value=yes%s>%s</option></select>', $name, ($default ? "" : " selected"), $n, ($default ? " selected" : ""), $y);
+}
+
+sub pkg_htmlselectsuite {
+ my $id = sprintf "b_%d_%d_%d", $_[0], $_[1], $_[2];
+ my @suites = ("stable", "testing", "unstable", "experimental");
+ my %suiteaka = ("stable", "etch", "testing", "lenny", "unstable", "sid");
+ my $defaultsuite = "unstable";
+
+ my $result = sprintf '<select name=dist id="%s">', $id;
+ for my $s (@suites) {
+ $result .= sprintf '<option value="%s"%s>%s%s</option>',
+ $s, ($defaultsuite eq $s ? " selected" : ""),
+ $s, (defined $suiteaka{$s} ? " (" . $suiteaka{$s} . ")" : "");
+ }
+ $result .= '</select>';
+ return $result;
+}
+
+sub pkg_htmlselectarch {
+ my $id = sprintf "b_%d_%d_%d", $_[0], $_[1], $_[2];
+ my @arches = qw(alpha amd64 arm hppa i386 ia64 m68k mips mipsel powerpc s390 sparc);
+
+ my $result = sprintf '<select name=arch id="%s">', $id;
+ $result .= '<option value="any">any architecture</option>';
+ for my $a (@arches) {
+ $result .= sprintf '<option value="%s">%s</option>', $a, $a;
+ }
+ $result .= '</select>';
+ return $result;
+}
+
+sub myurl {
+ my %param = @_;
+ return html_escape(pkg_url(map {exists $param{$_}?($_,$param{$_}):()}
+ qw(archive repeatmerged mindays maxdays),
+ qw(version dist arch package src tag maint submitter)
+ )
+ );
+}
+
+sub make_order_list {
+ my $vfull = shift;
+ my @x = ();
+
+ if ($vfull =~ m/^([^:]+):(.*)$/) {
+ my $v = $1;
+ for my $vv (split /,/, $2) {
+ push @x, "$v=$vv";
+ }
+ }
+ else {
+ for my $v (split /,/, $vfull) {
+ next unless $v =~ m/.=./;
+ push @x, $v;
+ }
+ }
+ push @x, ""; # catch all
+ return @x;
+}
+
+sub get_bug_order_index {
+ my $order = shift;
+ my $status = shift;
+ my $pos = -1;
+
+ my %tags = ();
+ %tags = map { $_, 1 } split / /, $status->{"tags"}
+ if defined $status->{"tags"};
+
+ for my $el (@${order}) {
+ $pos++;
+ my $match = 1;
+ for my $item (split /[+]/, $el) {
+ my ($f, $v) = split /=/, $item, 2;
+ next unless (defined $f and defined $v);
+ my $isokay = 0;
+ $isokay = 1 if (defined $status->{$f} and $v eq $status->{$f});
+ $isokay = 1 if ($f eq "tag" && defined $tags{$v});
+ unless ($isokay) {
+ $match = 0;
+ last;
+ }
+ }
+ if ($match) {
+ return $pos;
+ last;
+ }
+ }
+ return $pos + 1;
+}
+
+sub buglinklist {
+ my ($prefix, $infix, @els) = @_;
+ return '' if not @els;
+ return $prefix . bug_linklist($infix,'submitter',@els);
+}
+
+
+# sets: my @names; my @prior; my @title; my @order;
+
+sub determine_ordering {
+ my %param = validate_with(params => \@_,
+ spec => {cats => {type => HASHREF,
+ },
+ param => {type => HASHREF,
+ },
+ ordering => {type => SCALARREF,
+ },
+ names => {type => ARRAYREF,
+ },
+ pend_rev => {type => BOOLEAN,
+ default => 0,
+ },
+ sev_rev => {type => BOOLEAN,
+ default => 0,
+ },
+ prior => {type => ARRAYREF,
+ },
+ title => {type => ARRAYREF,
+ },
+ order => {type => ARRAYREF,
+ },
+ },
+ );
+ $param{cats}{status}[0]{ord} = [ reverse @{$param{cats}{status}[0]{ord}} ]
+ if ($param{pend_rev});
+ $param{cats}{severity}[0]{ord} = [ reverse @{$param{cats}{severity}[0]{ord}} ]
+ if ($param{sev_rev});
+
+ my $i;
+ if (defined $param{param}{"pri0"}) {
+ my @c = ();
+ $i = 0;
+ while (defined $param{param}{"pri$i"}) {
+ my $h = {};
+
+ my ($pri) = make_list($param{param}{"pri$i"});
+ if ($pri =~ m/^([^:]*):(.*)$/) {
+ $h->{"nam"} = $1; # overridden later if necesary
+ $h->{"pri"} = [ map { "$1=$_" } (split /,/, $2) ];
+ }
+ else {
+ $h->{"pri"} = [ split /,/, $pri ];
+ }
+
+ ($h->{"nam"}) = make_list($param{param}{"nam$i"})
+ if (defined $param{param}{"nam$i"});
+ $h->{"ord"} = [ map {split /\s*,\s*/} make_list($param{param}{"ord$i"}) ]
+ if (defined $param{param}{"ord$i"});
+ $h->{"ttl"} = [ map {split /\s*,\s*/} make_list($param{param}{"ttl$i"}) ]
+ if (defined $param{param}{"ttl$i"});
+
+ push @c, $h;
+ $i++;
+ }
+ $param{cats}{"_"} = [@c];
+ ${$param{ordering}} = "_";
+ }
+
+ ${$param{ordering}} = "normal" unless defined $param{cats}{${$param{ordering}}};
+
+ sub get_ordering {
+ my @res;
+ my $cats = shift;
+ my $o = shift;
+ for my $c (@{$cats->{$o}}) {
+ if (ref($c) eq "HASH") {
+ push @res, $c;
+ }
+ else {
+ push @res, get_ordering($cats, $c);
+ }
+ }
+ return @res;
+ }
+ my @cats = get_ordering($param{cats}, ${$param{ordering}});
+
+ sub toenglish {
+ my $expr = shift;
+ $expr =~ s/[+]/ and /g;
+ $expr =~ s/[a-z]+=//g;
+ return $expr;
+ }
+
+ $i = 0;
+ for my $c (@cats) {
+ $i++;
+ push @{$param{prior}}, $c->{"pri"};
+ push @{$param{names}}, ($c->{"nam"} || "Bug attribute #" . $i);
+ if (defined $c->{"ord"}) {
+ push @{$param{order}}, $c->{"ord"};
+ }
+ else {
+ push @{$param{order}}, [ 0..$#{$param{prior}[-1]} ];
+ }
+ my @t = @{ $c->{"ttl"} } if defined $c->{ttl};
+ if (@t < $#{$param{prior}[-1]}) {
+ push @t, map { toenglish($param{prior}[-1][$_]) } @t..($#{$param{prior}[-1]});
+ }
+ push @t, $c->{"def"} || "";
+ push @{$param{title}}, [@t];
+ }
+}
+
+
+
+
+1;
+
+
+__END__
+
+
+
+
+
+
qw(getmaintainers_reverse),
qw(getpseudodesc),
],
- misc => [qw(make_list)],
+ misc => [qw(make_list globify_scalar)],
date => [qw(secs_to_english)],
quit => [qw(quit)],
- lock => [qw(filelock unfilelock @cleanups lockpid)],
+ lock => [qw(filelock unfilelock lockpid)],
);
@EXPORT_OK = ();
Exporter::export_ok_tags(qw(lock quit date util misc));
}
#use Debbugs::Config qw(:globals);
+
+use Carp;
+
use Debbugs::Config qw(:config);
use IO::File;
+use IO::Scalar;
use Debbugs::MIME qw(decode_rfc1522);
use Mail::Address;
use Cwd qw(cwd);
=cut
sub appendfile {
- my $file = shift;
- if (!open(AP,">>$file")) {
- print $DEBUG_FH "failed open log<\n" if $DEBUG;
- print $DEBUG_FH "failed open log err $!<\n" if $DEBUG;
- &quit("opening $file (appendfile): $!");
- }
- print(AP @_) || &quit("writing $file (appendfile): $!");
- close(AP) || &quit("closing $file (appendfile): $!");
+ my ($file,@data) = @_;
+ my $fh = IO::File->new($file,'a') or
+ die "Unable top open $file for appending: $!";
+ print {$fh} @data or die "Unable to write to $file: $!";
+ close $fh or die "Unable to close $file: $!";
}
=head2 getparsedaddrs
return wantarray?@{$_parsedaddrs{$addr}}:$_parsedaddrs{$addr}[0];
}
+=head2 getmaintainers
+
+ my $maintainer = getmaintainers()->{debbugs}
+
+Returns a hashref of package => maintainer pairs.
+
+=cut
+
our $_maintainer;
our $_maintainer_rev;
sub getmaintainers {
my %maintainer_rev;
for my $file (@config{qw(maintainer_file maintainer_file_override pseduo_maint_file)}) {
next unless defined $file;
- my $maintfile = new IO::File $file,'r' or
- &quitcgi("Unable to open $file: $!");
+ my $maintfile = IO::File->new($file,'r') or
+ die "Unable to open maintainer file $file: $!";
while(<$maintfile>) {
next unless m/^(\S+)\s+(\S.*\S)\s*$/;
($a,$b)=($1,$2);
$_maintainer_rev = \%maintainer_rev;
return $_maintainer;
}
+
+=head2 getmaintainers_reverse
+
+ my @packages = @{getmaintainers_reverse->{'don@debian.org'}||[]};
+
+Returns a hashref of maintainer => [qw(list of packages)] pairs.
+
+=cut
+
sub getmaintainers_reverse{
return $_maintainer_rev if $_maintainer_rev;
getmaintainers();
=cut
our @filelocks;
-our @cleanups;
sub filelock {
# NB - NOT COMPATIBLE WITH `with-lock'
}
if (--$count <=0) {
$errors =~ s/\n+$//;
- &quit("failed to get lock on $lockfile -- $errors");
+ die "failed to get lock on $lockfile -- $errors";
}
sleep 10;
}
- push(@cleanups,\&unfilelock);
+}
+
+# clean up all outstanding locks at end time
+END {
+ while (@filelocks) {
+ unfilelock();
+ }
}
return;
}
my %fl = %{pop(@filelocks)};
- pop(@cleanups);
flock($fl{fh},LOCK_UN)
or warn "Unable to unlock lockfile $fl{file}: $!";
close($fl{fh})
or warn "Unable to unlink lockfile $fl{file}: $!";
}
+
=head2 lockpid
lockpid('/path/to/pidfile');
quit()
-Exits the program by calling die after running some cleanups.
+Exits the program by calling die.
-This should be replaced with an END handler which runs the cleanups
-instead. (Or possibly a die handler, if the cleanups are important)
+Usage of quit is deprecated; just call die instead.
=cut
sub quit {
- print $DEBUG_FH "quitting >$_[0]<\n" if $DEBUG;
- my ($u);
- while ($u= $cleanups[$#cleanups]) { &$u; }
- die "*** $_[0]\n";
+ print {$DEBUG_FH} "quitting >$_[0]<\n" if $DEBUG;
+ carp "quit() is deprecated; call die directly instead";
}
+
=head1 MISC
These functions are exported with the :misc tag
}
+=head2 globify_scalar
+
+ my $handle = globify_scalar(\$foo);
+
+if $foo isn't already a glob or a globref, turn it into one using
+IO::Scalar. Gives a new handle to /dev/null if $foo isn't defined.
+
+Will carp if given a scalar which isn't a scalarref or a glob (or
+globref), and return /dev/null. May return undef if IO::Scalar or
+IO::File fails. (Check $!)
+
+=cut
+
+sub globify_scalar {
+ my ($scalar) = @_;
+ my $handle;
+ if (defined $scalar) {
+ if (defined ref($scalar)) {
+ if (ref($scalar) eq 'SCALAR' and
+ not UNIVERSAL::isa($scalar,'GLOB')) {
+ return IO::Scalar->new($scalar);
+ }
+ else {
+ return $scalar;
+ }
+ }
+ elsif (UNIVERSAL::isa(\$scalar,'GLOB')) {
+ return $scalar;
+ }
+ else {
+ carp "Given a non-scalar reference, non-glob to globify_scalar; returning /dev/null handle";
+ }
+ }
+ return IO::File->new('/dev/null','w');
+}
+
1;
qw($gSubmitList $gMaintList $gQuietList $gForwardList),
qw($gDoneList $gRequestList $gSubmitterList $gControlList),
qw($gStrongList),
+ qw($gBugSubscriptionDomain),
qw($gPackageVersionRe),
qw($gSummaryList $gMirrorList $gMailer $gBug),
qw($gBugs $gRemoveAge $gSaveOldBugs $gDefaultSeverity),
qw($gVersionTimeIndex),
qw($gSendmail $gLibPath $gSpamScan @gExcludeFromControl),
qw(%gSeverityDisplay @gTags @gSeverityList @gStrongSeverities),
+ qw(%gTagsSingleLetter),
qw(%gSearchEstraier),
qw(%gDistributionAliases),
+ qw(%gObsoleteSeverities),
qw(@gPostProcessall @gRemovalDefaultDistributionTags @gRemovalDistributionTags @gRemovalArchitectures),
qw(@gRemovalStrongSeverityDefaultDistributionTags),
qw(@gDefaultArchitectures),
qw($gTemplateDir),
qw($gDefaultPackage),
- qw($gSpamMaxThreads $gSpamSpamsPerThread $gSpamKeepRunning $gSpamScan $gSpamCrossassassinDb)
+ qw($gSpamMaxThreads $gSpamSpamsPerThread $gSpamKeepRunning $gSpamScan $gSpamCrossassassinDb),
],
text => [qw($gBadEmailPrefix $gHTMLTail $gHTMLExpireNote),
],
@EXPORT_OK = ();
Exporter::export_ok_tags(qw(globals text config));
$EXPORT_TAGS{all} = [@EXPORT_OK];
+ $ENV{HOME} = '' if not defined $ENV{HOME};
}
use File::Basename qw(dirname);
=item mirror_list
-=back
-
=cut
set_default(\%config, 'submit_list', 'bug-submit-list');
set_default(\%config, 'mirror_list', 'bug-mirror-list');
set_default(\%config, 'strong_list', 'bug-strong-list');
+=item bug_subscription_domain
+
+Domain of list for messages regarding a single bug; prefixed with
+bug=${bugnum}@ when bugs are actually sent out. Set to undef or '' to
+disable sending messages to the bug subscription list.
+
+Default: list_domain
+
+=back
+
+=cut
+
+set_default(\%config,'bug_subscription_domain',$config{list_domain});
+
+
=head2 Misc Options
=over
[qw(i386 amd64 arm powerpc sparc alpha)]
);
+=item removal_unremovable_tags
+
+Bugs which have these tags set cannot be archived
+
+Default: []
+
+=cut
+
+set_default(\%config,'removal_unremovable_tags',
+ [],
+ );
+
=item removal_distribution_tags
Tags which specifiy distributions to check
+=item default_severity
+
+The default severity of bugs which have no severity set
+
+Default: normal
+
+=cut
set_default(\%config,'default_severity','normal');
-set_default(\%config,'show_severities','critical, grave, normal, minor, wishlist');
-set_default(\%config,'strong_severities',[qw(critical grave)]);
-set_default(\%config,'severity_list',[qw(critical grave normal wishlist)]);
+
+=item severity_display
+
+A hashref of severities and the informative text which describes them.
+
+Default:
+
+ {critical => "Critical $config{bugs}",
+ grave => "Grave $config{bugs}",
+ normal => "Normal $config{bugs}",
+ wishlist => "Wishlist $config{bugs}",
+ }
+
+=cut
+
set_default(\%config,'severity_display',{critical => "Critical $config{bugs}",
grave => "Grave $config{bugs}",
normal => "Normal $config{bugs}",
wishlist => "Wishlist $config{bugs}",
});
+=item show_severities
+
+A scalar list of the severities to show
+
+Defaults to the concatenation of the keys of the severity_display
+hashlist with ', ' above.
+
+=cut
+
+set_default(\%config,'show_severities',join(', ',keys %{$config{severity_display}}));
+
+=item strong_severities
+
+An arrayref of the serious severities which shoud be emphasized
+
+Default: [qw(critical grave)]
+
+=cut
+
+set_default(\%config,'strong_severities',[qw(critical grave)]);
+
+=item severity_list
+
+An arrayref of a list of the severities
+
+Defaults to the keys of the severity display hashref
+
+=cut
+
+set_default(\%config,'severity_list',[keys %{$config{severity_display}}]);
+
+=item obsolete_severities
+
+A hashref of obsolete severities with the replacing severity
+
+Default: {}
+
+=cut
+
+set_default(\%config,'obsolete_severities',{});
+
+=item tags
+
+An arrayref of the tags used
+
+Default: [qw(patch wontfix moreinfo unreproducible fixed)] and also
+includes the distributions.
+
+=cut
+
set_default(\%config,'tags',[qw(patch wontfix moreinfo unreproducible fixed),
@{$config{distributions}}
]);
+set_default(\%config,'tags_single_letter',
+ {patch => '+',
+ wontfix => '',
+ moreinfo => 'M',
+ unreproducible => 'R',
+ fixed => 'F',
+ }
+ );
+
set_default(\%config,'bounce_froms','^mailer|^da?emon|^post.*mast|^root|^wpuser|^mmdf|^smt.*|'.
'^mrgate|^vmmail|^mail.*system|^uucp|-maiser-|^mal\@|'.
'^mail.*agent|^tcpmail|^bitmail|^mailman');
set_default(\%config,'config_dir',dirname(exists $ENV{DEBBUGS_CONFIG_FILE}?$ENV{DEBBUGS_CONFIG_FILE}:'/etc/debbugs/config'));
set_default(\%config,'spool_dir','/var/lib/debbugs/spool');
+
+=item usertag_dir
+
+Directory which contains the usertags
+
+Default: $config{spool_dir}/user
+
+=cut
+
+set_default(\%config,'usertag_dir',$config{spool_dir}.'/user');
set_default(\%config,'incoming_dir','incoming');
set_default(\%config,'web_dir','/var/lib/debbugs/www');
set_default(\%config,'doc_dir','/var/lib/debbugs/www/txt');
set_default(\%config,'spam_rules_dir','/usr/share/spamassassin');
-
=back
This shows up at the end of (most) html pages
+In many pages this has been replaced by the html/tail template.
+
=cut
set_default(\%config,'html_tail',<<END);
is true, the above options must be present, and their values are used.
-=head1 FUNCTIONS
+=head1 GENERAL FUNCTIONS
=cut
$DEBUG = 0 unless defined $DEBUG;
@EXPORT = ();
- %EXPORT_TAGS = (archive => [qw(bug_archive bug_unarchive),
+ %EXPORT_TAGS = (owner => [qw(owner)],
+ archive => [qw(bug_archive bug_unarchive),
],
log => [qw(append_action_to_log),
],
);
@EXPORT_OK = ();
- Exporter::export_ok_tags(qw(archive log));
+ Exporter::export_ok_tags(keys %EXPORT_TAGS);
$EXPORT_TAGS{all} = [@EXPORT_OK];
}
use Debbugs::Config qw(:config);
-use Debbugs::Common qw(:lock buglog make_list get_hashname);
+use Debbugs::Common qw(:lock buglog :misc get_hashname);
use Debbugs::Status qw(bug_archiveable :read :hook writebug);
use Debbugs::CGI qw(html_escape);
use Debbugs::Log qw(:misc);
+use Debbugs::Recipients qw(:add);
use Params::Validate qw(validate_with :types);
use File::Path qw(mkpath);
use IO::File;
-use IO::Scalar;
use Debbugs::Text qw(:templates);
use POSIX qw(strftime);
+use Carp;
+
# These are a set of options which are common to all of these functions
-my %common_options = (debug => {type => SCALARREF,
+my %common_options = (debug => {type => SCALARREF|HANDLE,
optional => 1,
},
- transcript => {type => SCALARREF,
+ transcript => {type => SCALARREF|HANDLE,
optional => 1,
},
affected_bugs => {type => HASHREF,
optional => 1,
},
+ affected_packages => {type => HASHREF,
+ optional => 1,
+ },
+ recipients => {type => HASHREF,
+ default => {},
+ },
+ limit => {type => HASHREF,
+ default => {},
+ },
);
);
+# this is just a generic stub for Debbugs::Control functions.
+# sub foo {
+# my %param = validate_with(params => \@_,
+# spec => {bug => {type => SCALAR,
+# regex => qr/^\d+$/,
+# },
+# # specific options here
+# %common_options,
+# %append_action_options,
+# },
+# );
+# our $locks = 0;
+# $locks = 0;
+# local $SIG{__DIE__} = sub {
+# if ($locks) {
+# for (1..$locks) { unfilelock(); }
+# $locks = 0;
+# }
+# };
+# my ($debug,$transcript) = __handle_debug_transcript(%param);
+# my (@data);
+# ($locks, @data) = lock_read_all_merged_bugs($param{bug});
+# __handle_affected_packages(data => \@data,%param);
+# add_recipients(data => \@data,
+# recipients => $param{recipients}
+# );
+# }
+
+=head1 OWNER FUNCTIONS
+
+=head2 owner
+
+ eval {
+ owner(bug => $ref,
+ transcript => $transcript,
+ ($dl > 0 ? (debug => $transcript):()),
+ requester => $header{from},
+ request_addr => $controlrequestaddr,
+ message => \@log,
+ recipients => \%recipients,
+ owner => undef,
+ );
+ };
+ if ($@) {
+ $errors++;
+ print {$transcript} "Failed to mark $ref as having an owner: $@";
+ }
+
+Handles all setting of the owner field; given an owner of undef or of
+no length, indicates that a bug is not owned by anyone.
+
+=cut
+
+sub owner {
+ my %param = validate_with(params => \@_,
+ spec => {bug => {type => SCALAR,
+ regex => qr/^\d+$/,
+ },
+ owner => {type => SCALAR|UNDEF,
+ },
+ %common_options,
+ %append_action_options,
+ },
+ );
+ our $locks = 0;
+ $locks = 0;
+ local $SIG{__DIE__} = sub {
+ if ($locks) {
+ for (1..$locks) { unfilelock(); }
+ $locks = 0;
+ }
+ };
+ my ($debug,$transcript) = __handle_debug_transcript(%param);
+ my (@data);
+ ($locks, @data) = lock_read_all_merged_bugs($param{bug});
+ __handle_affected_packages(data => \@data,%param);
+ @data and defined $data[0] or die "No bug found for $param{bug}";
+ add_recipients(data => \@data,
+ recipients => $param{recipients}
+ );
+ my $action = '';
+ for my $data (@data) {
+ print {$debug} "Going to change owner to '".(defined $param{owner}?$param{owner}:'(going to unset it)')."'\n";
+ print {$debug} "Owner is currently '$data->{owner}' for bug $data->{bug_num}\n";
+ if (not defined $param{owner} or not length $param{owner}) {
+ $param{owner} = '';
+ $action = "Removed annotation that $config{bug} was owned by " .
+ "$data->{owner}.";
+ }
+ else {
+ if (length $data->{owner}) {
+ $action = "Owner changed from $data->{owner} to $param{owner}.";
+ }
+ else {
+ $action = "Owner recorded as $param{owner}."
+ }
+ }
+ $data->{owner} = $param{owner};
+ append_action_to_log(bug => $data->{bug_num},
+ get_lock => 0,
+ __return_append_to_log_options(
+ %param,
+ action => $action,
+ ),
+ )
+ if not exists $param{append_log} or $param{append_log};
+ writebug($data->{bug_num},$data);
+ print {$transcript} "$action\n";
+ add_recipients(data => $data,
+ recipients => $param{recipients},
+ );
+ }
+ if ($locks) {
+ for (1..$locks) { unfilelock(); }
+ }
+}
+
+
+=head1 ARCHIVE FUNCTIONS
+
+
=head2 bug_archive
my $error = '';
This routine archives a bug
+=over
+
+=item bug -- bug number
+
+=item check_archiveable -- check wether a bug is archiveable before
+archiving; defaults to 1
+
+=item archive_unarchived -- whether to archive bugs which have not
+previously been archived; defaults to 1. [Set to 0 when used from
+control@]
+
+=item ignore_time -- whether to ignore time constraints when archiving
+a bug; defaults to 0.
+
+=back
+
=cut
sub bug_archive {
check_archiveable => {type => BOOLEAN,
default => 1,
},
+ archive_unarchived => {type => BOOLEAN,
+ default => 1,
+ },
ignore_time => {type => BOOLEAN,
default => 0,
},
},
);
our $locks = 0;
+ $locks = 0;
local $SIG{__DIE__} = sub {
if ($locks) {
for (1..$locks) { unfilelock(); }
die "Bug $param{bug} cannot be archived";
}
print {$debug} "$param{bug} considering\n";
- my ($data);
- ($locks, $data) = lockreadbugmerge($param{bug});
+ my (@data);
+ ($locks, @data) = lock_read_all_merged_bugs($param{bug});
+ __handle_affected_packages(data => \@data,%param);
print {$debug} "$param{bug} read $locks\n";
- defined $data or die "No bug found for $param{bug}";
- print {$debug} "$param{bug} read ok (done $data->{done})\n";
+ @data and defined $data[0] or die "No bug found for $param{bug}";
print {$debug} "$param{bug} read done\n";
- my @bugs = ($param{bug});
- # my %bugs;
- # @bugs{@bugs} = (1) x @bugs;
- if (length($data->{mergedwith})) {
- push(@bugs,split / /,$data->{mergedwith});
+
+ if (not $param{archive_unarchived} and
+ not exists $data[0]{unarchived}
+ ) {
+ print {$transcript} "$param{bug} has not been archived previously\n";
+ die "$param{bug} has not been archived previously";
}
+ add_recipients(recipients => $param{recipients},
+ data => \@data,
+ );
+ my @bugs = map {$_->{bug_num}} @data;
print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
for my $bug (@bugs) {
- my $newdata;
- print {$debug} "$param{bug} $bug check\n";
- if ($bug != $param{bug}) {
- print {$debug} "$param{bug} $bug reading\n";
- $newdata = lockreadbug($bug) || die "huh $bug ?";
- print {$debug} "$param{bug} $bug read ok\n";
- $locks++;
- } else {
- $newdata = $data;
- }
- print {$debug} "$param{bug} $bug read/not\n";
- my $expectmerge= join(' ',grep($_ != $bug, sort { $a <=> $b } @bugs));
- $newdata->{mergedwith} eq $expectmerge ||
- die "$param{bug} differs from $bug: ($newdata->{mergedwith}) vs. ($expectmerge) (".join(' ',@bugs).")";
- print {$debug} "$param{bug} $bug merge-ok\n";
- if ($param{check_archiveable}) {
- die "Bug $bug cannot be archived (but $param{bug} can?)"
- unless bug_archiveable(bug=>$bug,
- ignore_time => $param{ignore_time},
- );
- }
+ if ($param{check_archiveable}) {
+ die "Bug $bug cannot be archived (but $param{bug} can?)"
+ unless bug_archiveable(bug=>$bug,
+ ignore_time => $param{ignore_time},
+ );
+ }
}
# If we get here, we can archive/remove this bug
print {$debug} "$param{bug} removing\n";
append_action_to_log(bug => $bug,
get_lock => 0,
__return_append_to_log_options(
- (map {exists $param{$_}?($_,$param{$_}):()}
- keys %append_action_options,
- ),
+ %param,
action => $action,
)
)
if not exists $param{append_log} or $param{append_log};
- my @files_to_remove = map {s#db-h/$dir/##; $_} glob("db-h/$dir/$bug.*");
+ my @files_to_remove = map {s#$config{spool_dir}/db-h/$dir/##; $_} glob("$config{spool_dir}/db-h/$dir/$bug.*");
if ($config{save_old_bugs}) {
- mkpath("archive/$dir");
+ mkpath("$config{spool_dir}/archive/$dir");
foreach my $file (@files_to_remove) {
- link( "db-h/$dir/$file", "archive/$dir/$file" ) || copy( "db-h/$dir/$file", "archive/$dir/$file" );
+ link( "$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file" ) or
+ copy( "$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file" );
}
print {$transcript} "archived $bug to archive/$dir (from $param{bug})\n";
}
- unlink(map {"db-h/$dir/$_"} @files_to_remove);
+ unlink(map {"$config{spool_dir}/db-h/$dir/$_"} @files_to_remove);
print {$transcript} "deleted $bug (from $param{bug})\n";
}
bughook_archive(@bugs);
%append_action_options,
},
);
+ our $locks = 0;
+ local $SIG{__DIE__} = sub {
+ if ($locks) {
+ for (1..$locks) { unfilelock(); }
+ $locks = 0;
+ }
+ };
my $action = "$config{bug} unarchived.";
my ($debug,$transcript) = __handle_debug_transcript(%param);
print {$debug} "$param{bug} considering\n";
- my ($locks, $data) = lockreadbugmerge($param{bug},'archive');
+ my @data = ();
+ ($locks, @data) = lock_read_all_merged_bugs($param{bug},'archive');
+ __handle_affected_packages(data => \@data,%param);
print {$debug} "$param{bug} read $locks\n";
- if (not defined $data) {
- print {$transcript} "No bug found for $param{bug}\n";
- die "No bug found for $param{bug}";
+ if (not @data or not defined $data[0]) {
+ print {$transcript} "No bug found for $param{bug}\n";
+ die "No bug found for $param{bug}";
}
- print {$debug} "$param{bug} read ok (done $data->{done})\n";
print {$debug} "$param{bug} read done\n";
- my @bugs = ($param{bug});
- # my %bugs;
- # @bugs{@bugs} = (1) x @bugs;
- if (length($data->{mergedwith})) {
- push(@bugs,split / /,$data->{mergedwith});
- }
+ my @bugs = map {$_->{bug_num}} @data;
print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
- for my $bug (@bugs) {
- my $newdata;
- print {$debug} "$param{bug} $bug check\n";
- if ($bug != $param{bug}) {
- print {$debug} "$param{bug} $bug reading\n";
- $newdata = lockreadbug($bug,'archive') or die "huh $bug ?";
- print {$debug} "$param{bug} $bug read ok\n";
- $locks++;
- } else {
- $newdata = $data;
- }
- print {$debug} "$param{bug} $bug read/not\n";
- my $expectmerge= join(' ',grep($_ != $bug, sort { $a <=> $b } @bugs));
- if ($newdata->{mergedwith} ne $expectmerge ) {
- print {$transcript} "$param{bug} differs from $bug: ($newdata->{mergedwith}) vs. ($expectmerge) (@bugs)";
- die "$param{bug} differs from $bug: ($newdata->{mergedwith}) vs. ($expectmerge) (@bugs)";
- }
- print {$debug} "$param{bug} $bug merge-ok\n";
- }
- # If we get here, we can archive/remove this bug
- print {$debug} "$param{bug} removing\n";
+ print {$debug} "$param{bug} unarchiving\n";
my @files_to_remove;
for my $bug (@bugs) {
print {$debug} "$param{bug} removing $bug\n";
my $dir = get_hashname($bug);
- my @files_to_copy = map {s#archive/$dir/##; $_} glob("archive/$dir/$bug.*");
+ my @files_to_copy = map {s#$config{spool_dir}/archive/$dir/##; $_} glob("$config{spool_dir}/archive/$dir/$bug.*");
mkpath("archive/$dir");
foreach my $file (@files_to_copy) {
# die'ing here sucks
- link( "archive/$dir/$file", "db-h/$dir/$file" ) or
- copy( "archive/$dir/$file", "db-h/$dir/$file" ) or
- die "Unable to copy archive/$dir/$file to db-h/$dir/$file";
+ link( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
+ copy( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
+ die "Unable to copy $config{spool_dir}/archive/$dir/$file to $config{spool_dir}/db-h/$dir/$file";
}
- push @files_to_remove, map {"archive/$dir/$_"} @files_to_copy;
+ push @files_to_remove, map {"$config{spool_dir}/archive/$dir/$_"} @files_to_copy;
print {$transcript} "Unarchived $config{bug} $bug\n";
}
unlink(@files_to_remove) or die "Unable to unlink bugs";
append_action_to_log(bug => $bug,
get_lock => 0,
__return_append_to_log_options(
- (map {exists $param{$_}?($_,$param{$_}):()}
- keys %append_action_options,
- ),
+ %param,
action => $action,
)
)
if not exists $param{append_log} or $param{append_log};
writebug($bug,$newdata);
+ add_recipients(recipients => $param{recipients},
+ data => $newdata,
+ );
}
print {$debug} "$param{bug} unlocking $locks\n";
if ($locks) {
=head1 PRIVATE FUNCTIONS
+=head2 __handle_affected_packages
+
+ __handle_affected_packages(affected_packages => {},
+ data => [@data],
+ )
+
+
+
+=cut
+
+sub __handle_affected_packages{
+ my %param = validate_with(params => \@_,
+ spec => {%common_options,
+ data => {type => ARRAYREF|HASHREF
+ },
+ },
+ allow_extra => 1,
+ );
+ for my $data (make_list($param{data})) {
+ $param{affected_packages}{$data->{package}} = 1;
+ }
+}
+
=head2 __handle_debug_transcript
my ($debug,$transcript) = __handle_debug_transcript(%param);
-Returns a debug and transcript IO::Scalar filehandle
+Returns a debug and transcript filehandle
=cut
spec => {%common_options},
allow_extra => 1,
);
- my $fake_scalar;
- my $debug = IO::Scalar->new(exists $param{debug}?$param{debug}:\$fake_scalar);
- my $transcript = IO::Scalar->new(exists $param{transcript}?$param{transcript}:\$fake_scalar);
+ my $debug = globify_scalar(exists $param{debug}?$param{debug}:undef);
+ my $transcript = globify_scalar(exists $param{transcript}?$param{transcript}:undef);
return ($debug,$transcript);
-
}
sub __return_append_to_log_options{
my %param = @_;
- my $action = 'Unknown action';
+ my $action = $param{action} if exists $param{action};
if (not exists $param{requester}) {
$param{requester} = $config{control_internal_requester};
}
$param{request_addr} = $config{control_internal_request_addr};
}
if (not exists $param{message}) {
- $action = $param{action} if exists $param{action};
my $date = rfc822_date();
$param{message} = fill_in_template(template => 'mail/fake_control_message',
variables => {request_addr => $param{request_addr},
},
);
}
+ if (not defined $action) {
+ carp "Undefined action!";
+ $action = "unknown action";
+ }
return (action => $action,
- %param);
+ (map {exists $append_action_options{$_}?($_,$param{$_}):()}
+ keys %param),
+ );
}
$EXPORT_TAGS{all} = [@EXPORT_OK];
}
+use Carp;
+
+use Debbugs::Common qw(getbuglocation getbugcomponent);
+use Params::Validate qw(:types validate_with);
+
=head1 NAME
Debbugs::Log - an interface to debbugs .log files
Creates a new log reader based on a .log filehandle.
+ my $log = Debbugs::Log->new($logfh);
+ my $log = Debbugs::Log->new(bug_num => $nnn);
+ my $log = Debbugs::Log->new(logfh => $logfh);
+
+Parameters
+
+=over
+
+=item bug_num -- bug number
+
+=item logfh -- log filehandle
+
+=item log_name -- name of log
+
+=back
+
+One of the above options must be passed.
+
=cut
sub new
{
my $this = shift;
+ my %param;
+ if (@_ == 1) {
+ ($param{logfh}) = @_;
+ }
+ else {
+ %param = validate_with(params => \@_,
+ spec => {bug_num => {type => SCALAR,
+ optional => 1,
+ },
+ logfh => {type => SCALAR,
+ optional => 1,
+ },
+ log_name => {type => SCALAR,
+ optional => 1,
+ },
+ }
+ );
+ }
+ 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;
my $self = {};
bless $self, $class;
- $self->{logfh} = shift;
+
+ 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->{state} = 'kill-init';
$self->{linenum} = 0;
return $self;
return undef;
}
-sub parse ($)
+sub parse
{
# header and decoded body respectively
my (@headerlines, @bodylines);
- my $parser = new MIME::Parser;
+ my $parser = MIME::Parser->new();
mkdir "mime.tmp.$$", 0777;
$parser->output_under("mime.tmp.$$");
my $entity = eval { $parser->parse_data($_[0]) };
]));
}
-sub decode_rfc1522 ($)
-{
+sub decode_rfc1522 {
my ($string) = @_;
# this is craptacular, but leading space is hacked off by unmime.
# We cannot use MIME::Words::encode_mimewords because that function
# does not handle spaces properly at all.
-sub encode_rfc1522 ($) {
+sub encode_rfc1522 {
my ($rawstr) = @_;
# handle being passed undef properly
use warnings;
use strict;
-use Debbugs::Config qw(:config :globals);
-
use base qw(Exporter);
use vars qw($VERSION @EXPORT_OK %EXPORT_TAGS @EXPORT);
+use Debbugs::Config qw(:config :globals);
+
BEGIN {
$VERSION = 1.00;
use List::Util qw(min max);
+use IO::File;
+
$MLDBM::DumpMeth = 'portable';
$MLDBM::RemoveTaint = 1;
my %pkgcomponent;
my %srcpkg;
- open(MM,"$Debbugs::Packages::gPackageSource")
- or die("open $Debbugs::Packages::gPackageSource: $!");
- while(<MM>) {
+ my $fh = IO::File->new($config{package_source},'r')
+ or die("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);
- $bin =~ y/A-Z/a-z/;
+ $bin = lc($bin);
$pkgsrc{$bin}= $src;
push @{$srcpkg{$src}}, $bin;
$pkgcomponent{$bin}= $cmp;
}
- close(MM);
+ close($fh);
$_pkgsrc = \%pkgsrc;
$_pkgcomponent = \%pkgcomponent;
$_srcpkg = \%srcpkg;
--- /dev/null
+# This module is part of debbugs, and is released
+# under the terms of the GPL version 2, or any later version. See the
+# file README and COPYING for more information.
+# Copyright 2008 by Don Armstrong <don@donarmstrong.com>.
+# $Id: perl_module_header.pm 1221 2008-05-19 15:00:40Z don $
+
+package Debbugs::Recipients;
+
+=head1 NAME
+
+Debbugs::Recipients -- Determine recipients of messages from the bts
+
+=head1 SYNOPSIS
+
+
+=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) = q$Revision: 1221 $ =~ /^Revision:\s+([^\s+])/;
+ $DEBUG = 0 unless defined $DEBUG;
+
+ @EXPORT = ();
+ %EXPORT_TAGS = (add => [qw(add_recipients)],
+ det => [qw(determine_recipients)],
+ );
+ @EXPORT_OK = ();
+ Exporter::export_ok_tags(keys %EXPORT_TAGS);
+ $EXPORT_TAGS{all} = [@EXPORT_OK];
+
+}
+
+use Debbugs::Config qw(:config);
+use Params::Validate qw(:types validate_with);
+use Debbugs::Common qw(:misc :util);
+use Debbugs::Status qw(splitpackages isstrongseverity);
+
+use Debbugs::Mail qw(get_addresses);
+
+use Carp;
+
+=head2 add_recipients
+
+ add_recipients(data => $data,
+ recipients => \%recipients;
+ );
+
+Given data (from read_bug or similar) (or an arrayref of data),
+calculates the addresses which need to receive mail involving this
+bug.
+
+=over
+
+=item data -- Data from read_bug or similar; can be an arrayref of data
+
+=item recipients -- hashref of recipient data structure; pass to
+subsequent calls of add_recipients or
+
+=item debug -- optional
+
+
+=back
+
+=cut
+
+
+sub add_recipients {
+ # Data structure is:
+ # maintainer email address &c -> assoc of packages -> assoc of bug#'s
+ my %param = validate_with(params => \@_,
+ spec => {data => {type => HASHREF|ARRAYREF,
+ },
+ recipients => {type => HASHREF,
+ },
+ debug => {type => HANDLE|SCALARREF,
+ optional => 1,
+ },
+ transcript => {type => HANDLE|SCALARREF,
+ optional => 1,
+ },
+ actions_taken => {type => HASHREF,
+ default => {},
+ },
+ },
+ );
+
+ $param{transcript} = globify_scalar($param{transcript});
+ $param{debug} = globify_scalar($param{debug});
+ if (ref ($param{data}) eq 'ARRAY') {
+ for my $data (@{$param{data}}) {
+ add_recipients(data => $data,
+ map {exists $param{$_}?($_,$param{$_}):()}
+ qw(recipients debug transcript actions_taken)
+ );
+ }
+ return;
+ }
+ my ($p, $addmaint);
+ my $anymaintfound=0; my $anymaintnotfound=0;
+ my $ref = $param{data}{bug_num};
+ for my $p (splitpackages($param{data}{package})) {
+ $p = lc($p);
+ if (defined $config{subscription_domain}) {
+ my @source_packages = binarytosource($p);
+ if (@source_packages) {
+ for my $source (@source_packages) {
+ _add_address(recipients => $param{recipients},
+ address => "$source\@".$config{subscription_domain},
+ reason => $source,
+ type => 'bcc',
+ );
+ }
+ }
+ else {
+ _add_address(recipients => $param{recipients},
+ address => "$p\@".$config{subscription_domain},
+ reason => $p,
+ type => 'bcc',
+ );
+ }
+ }
+ if (defined $param{data}{severity} and defined $config{strong_list} and
+ isstrongseverity($param{data}{severity})) {
+ _add_address(recipients => $param{recipients},
+ address => "$config{strong_list}\@".$config{list_domain},
+ reason => $param{data}{severity},
+ type => 'bcc',
+ );
+ }
+ if (defined(getmaintainers()->{$p})) {
+ $addmaint= getmaintainers()->{$p};
+ print {$param{debug}} "MR|$addmaint|$p|$ref|\n";
+ _add_address(recipients => $param{recipients},
+ address => $addmaint,
+ reason => $p,
+ bug_num => $param{data}{bug_num},
+ type => 'cc',
+ );
+ print {$param{debug}} "maintainer add >$p|$addmaint<\n";
+ }
+ else {
+ print {$param{debug}} "maintainer none >$p<\n";
+ print {$param{transcript}} "Warning: Unknown package '$p'\n";
+ print {$param{debug}} "MR|unknown-package|$p|$ref|\n";
+ _add_address(recipients => $param{recipients},
+ address => $config{unknown_maintainer_email},
+ reason => $p,
+ bug_num => $param{data}{bug_num},
+ type => 'cc',
+ )
+ if defined $config{unknown_maintainer_email} and
+ length $config{unknown_maintainer_email};
+ }
+ }
+ if (defined $config{bug_subscription_domain} and
+ length $config{bug_subscription_domain}) {
+ _add_address(recipients => $param{recipients},
+ address => 'bug='.$param{data}{bug_num}.'@'.
+ $config{bug_subscription_domain},
+ reason => "bug $param{data}{bug_num}",
+ bug_num => $param{data}{bug_num},
+ type => 'bcc',
+ );
+ }
+
+ if (length $param{data}{owner}) {
+ $addmaint = $param{data}{owner};
+ print {$param{debug}} "MO|$addmaint|$param{data}{package}|$ref|\n";
+ _add_address(recipients => $param{recipients},
+ address => $addmaint,
+ reason => "owner of $param{data}{bug_num}",
+ bug_num => $param{data}{bug_num},
+ type => 'cc',
+ );
+ print {$param{debug}} "owner add >$param{data}{package}|$addmaint<\n";
+ }
+ if (exists $param{actions_taken}) {
+ if (exists $param{actions_taken}{done} and
+ $param{actions_taken}{done} and
+ length($config{done_list}) and
+ length($config{list_domain})
+ ) {
+ _add_address(recipients => $param{recipients},
+ type => 'cc',
+ address => $config{done_list}.'@'.$config{list_domain},
+ bug_num => $param{data}{bug_num},
+ reason => "bug $param{data}{bug_num} done",
+ );
+ }
+ if (exists $param{actions_taken}{forwarded} and
+ $param{actions_taken}{forwarded} and
+ length($config{forward_list}) and
+ length($config{list_domain})
+ ) {
+ _add_address(recipients => $param{recipients},
+ type => 'cc',
+ address => $config{forward_list}.'@'.$config{list_domain},
+ bug_num => $param{data}{bug_num},
+ reason => "bug $param{data}{bug_num} forwarded",
+ );
+ }
+ }
+}
+
+=head2 determine_recipients
+
+ my @recipients = determine_recipients(recipients => \%recipients,
+ bcc => 1,
+ );
+ my %recipients => determine_recipients(recipients => \%recipients,);
+
+ # or a crazy example:
+ send_mail_message(message => $message,
+ recipients =>
+ [make_list(
+ values %{{determine_recipients(
+ recipients => \%recipients)
+ }})
+ ],
+ );
+
+Using the recipient hashref, determines the set of recipients.
+
+If you specify one of C<bcc>, C<cc>, or C<to>, you will receive only a
+LIST of recipients which the main should be Bcc'ed, Cc'ed, or To'ed
+respectively. By default, a LIST with keys bcc, cc, and to is returned
+with ARRAYREF values correponding to the users to whom a message
+should be sent.
+
+=over
+
+=item address_only -- whether to only return mail addresses without reasons or realnamesq
+
+=back
+
+Passing more than one of bcc, cc or to is a fatal error.
+
+=cut
+
+sub determine_recipients {
+ my %param = validate_with(params => \@_,
+ spec => {recipients => {type => HASHREF,
+ },
+ bcc => {type => BOOLEAN,
+ default => 0,
+ },
+ cc => {type => BOOLEAN,
+ default => 0,
+ },
+ to => {type => BOOLEAN,
+ default => 0,
+ },
+ address_only => {type => BOOLEAN,
+ default => 0,
+ }
+ },
+ );
+
+ if (1 < scalar grep {$param{$_}} qw(to cc bcc)) {
+ croak "Passing more than one of to, cc, or bcc is non-sensical";
+ }
+
+ my %final_recipients;
+ # start with the to recipients
+ for my $addr (keys %{$param{recipients}}) {
+ my $level = 'bcc';
+ my @reasons;
+ for my $reason (keys %{$param{recipients}{$addr}}) {
+ my @bugs;
+ for my $bug (keys %{$param{recipients}{$addr}{$reason}}) {
+ push @bugs, $bug;
+ my $t_level = $param{recipients}{$addr}{$reason}{$bug};
+ if ($level eq 'to' or
+ $t_level eq 'to') {
+ $level = 'to';
+ }
+ elsif ($t_level eq 'cc') {
+ $level = 'cc';
+ }
+ }
+ # strip out all non-word non-spaces
+ $reason =~ s/[^\ \w]//g;
+ push @reasons, $reason . ' for {'.join(',',@bugs).'}';
+ }
+ if ($param{address_only}) {
+ push @{$final_recipients{$level}}, get_addresses($addr);
+ }
+ else {
+ push @{$final_recipients{$level}}, $addr . ' ('.join(', ',@reasons).')';
+ }
+ }
+ for (qw(to cc bcc)) {
+ if ($param{$_}) {
+ return @{$final_recipients{$_}};
+ }
+ }
+ return %final_recipients;
+}
+
+
+=head1 PRIVATE FUNCTIONS
+
+=head2 _add_address
+
+ _add_address(recipients => $param{recipients},
+ address => $addmaint,
+ reason => $param{data}{package},
+ bug_num => $param{data}{bug_num},
+ type => 'cc',
+ );
+
+
+=cut
+
+
+sub _add_address {
+ my %param = validate_with(params => \@_,
+ spec => {recipients => {type => HASHREF,
+ },
+ bug_num => {type => SCALAR,
+ regex => qr/^\d*$/,
+ default => '',
+ },
+ reason => {type => SCALAR,
+ default => '',
+ },
+ address => {type => SCALAR|ARRAYREF,
+ },
+ type => {type => SCALAR,
+ default => 'cc',
+ regex => qr/^(?:b?cc|to)$/i,
+ },
+ },
+ );
+ for my $addr (make_list($param{address})) {
+ if (lc($param{type}) eq 'bcc' and
+ exists $param{recipients}{$addr}{$param{reason}}{$param{bug_num}}
+ ) {
+ next;
+ }
+ elsif (lc($param{type}) eq 'cc' and
+ exists $param{recipients}{$addr}{$param{reason}}{$param{bug_num}}
+ and $param{recipients}{$addr}{$param{reason}}{$param{bug_num}} eq 'to'
+ ) {
+ next;
+ }
+ $param{recipients}{$addr}{$param{reason}}{$param{bug_num}} = lc($param{type});
+ }
+}
+
+1;
+
+
+__END__
+
+
+
+
+
+
my $VERSION = __populate_version(pop);
my ($self,$bug,$msg_num) = @_;
- my $location = getbuglocation($bug,'log');
- my $bug_log = getbugcomponent($bug,'log',$location);
-
- my $log_fh = IO::File->new($bug_log, 'r') or
- die "Unable to open bug log $bug_log for reading: $!";
-
- my $log = Debbugs::Log->new($log_fh) or
+ my $log = Debbugs::Log->new(bug_num => $bug) or
die "Debbugs::Log was unable to be initialized";
my %seen_msg_ids;
use warnings;
use strict;
+
use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
use base qw(Exporter);
%EXPORT_TAGS = (status => [qw(splitpackages get_bug_status buggy bug_archiveable),
qw(isstrongseverity bug_presence),
],
- read => [qw(readbug read_bug lockreadbug lockreadbugmerge)],
+ read => [qw(readbug read_bug lockreadbug lockreadbugmerge),
+ qw(lock_read_all_merged_bugs),
+ ],
write => [qw(writebug makestatus unlockwritebug)],
versions => [qw(addfoundversions addfixedversions),
qw(removefoundversions removefixedversions)
=item summary -- complete path to the .summary file which will be read
+=item lock -- whether to obtain a lock for the bug to prevent
+something modifying it while the bug has been read. You B<must> call
+C<unfilelock();> if something not undef is returned from read_bug.
+
=back
One of C<bug> or C<summary> must be passed. This function will return
summary => {type => SCALAR,
optional => 1,
},
+ lock => {type => BOOLEAN,
+ optional => 1,
+ },
},
);
die "One of bug or summary must be passed to read_bug"
$log =~ s/\.summary$/.log/;
($location) = $status =~ m/(db-h|db|archive)/;
}
- my $status_fh = new IO::File $status, 'r' or
- warn "Unable to open $status for reading: $!" and return undef;
+ if ($param{lock}) {
+ filelock("$config{spool_dir}/lock/$param{bug}");
+ }
+ my $status_fh = IO::File->new($status, 'r');
+ if (not defined $status_fh) {
+ warn "Unable to open $status for reading: $!";
+ if ($param{lock}) {
+ unfilelock();
+ }
+ return undef;
+ }
my %data;
my @lines;
}
# Version 3 is the latest format version currently supported.
- return undef if $version > 3;
+ if ($version > 3) {
+ warn "Unsupported status version '$version'";
+ if ($param{lock}) {
+ unfilelock();
+ }
+ return undef;
+ }
my %namemap = reverse %fields;
for my $line (@lines) {
# Add log last modified time
$data{log_modified} = (stat($log))[9];
$data{location} = $location;
+ $data{archived} = $location eq 'archive';
+ $data{bug_num} = $param{bug};
return \%data;
}
sub lockreadbug {
my ($lref, $location) = @_;
- &filelock("lock/$lref");
- my $data = read_bug(bug => $lref, location => $location);
- &unfilelock unless defined $data;
- return $data;
+ return read_bug(bug => $lref, location => $location, lock => 1);
}
=head2 lockreadbugmerge
return (1,$data);
}
unfilelock();
- filelock('lock/merge');
+ filelock("$config{spool_dir}/lock/merge");
$data = lockreadbug(@_);
if (not defined $data) {
unfilelock();
return (2,$data);
}
+=head2 lock_read_all_merged_bugs
+
+ my ($locks,@bug_data) = lock_read_all_merged_bugs($bug_num,$location);
+
+Performs a filelock, then reads the bug passed. If the bug is merged,
+locks the merge lock, then reads and locks all of the other merged
+bugs. Returns a list of the number of locks and the bug data for all
+of the merged bugs.
+
+Will also return undef if any of the merged bugs failed to be read,
+even if all of the others were read properly.
+
+=cut
+
+sub lock_read_all_merged_bugs {
+ my ($bug_num,$location) = @_;
+ my @data = (lockreadbug(@_));
+ if (not @data and not defined $data[0]) {
+ return (0,undef);
+ }
+ if (not length $data[0]->{mergedwith}) {
+ return (1,@data);
+ }
+ unfilelock();
+ filelock("$config{spool_dir}/lock/merge");
+ my $locks = 0;
+ @data = (lockreadbug(@_));
+ if (not @data and not defined $data[0]) {
+ unfilelock(); #for merge lock above
+ return (0,undef);
+ }
+ $locks++;
+ my @bugs = split / /, $data[0]->{mergedwith};
+ for my $bug (@bugs) {
+ my $newdata = undef;
+ if ($bug ne $bug_num) {
+ $newdata = lockreadbug($bug,$location);
+ if (not defined $newdata) {
+ for (1..$locks) {
+ unfilelock();
+ }
+ $locks = 0;
+ warn "Unable to read bug: $bug while handling merged bug: $bug_num";
+ return ($locks,undef);
+ }
+ $locks++;
+ push @data,$newdata;
+ }
+ # perform a sanity check to make sure that the merged bugs are
+ # all merged with eachother
+ my $expectmerge= join(' ',grep($_ != $bug, sort { $a <=> $b } @bugs));
+ if ($newdata->{mergedwith} ne $expectmerge) {
+ for (1..$locks) {
+ unfilelock();
+ }
+ die "Bug $bug_num differs from bug $bug: ($newdata->{mergedwith}) vs. ($expectmerge) (".join(' ',@bugs).")";
+ }
+ }
+ return (2,@data);
+}
+
my @v1fieldorder = qw(originator date subject msgid package
keywords done forwarded mergedwith severity);
for my $version (keys %outputs) {
next if defined $minversion and $version < $minversion;
my $status = getbugcomponent($ref, $outputs{$version}, $location);
- &quit("can't find location for $ref") unless defined $status;
- open(S,"> $status.new") || &quit("opening $status.new: $!");
+ die "can't find location for $ref" unless defined $status;
+ open(S,"> $status.new") || die "opening $status.new: $!";
print(S makestatus($data, $version)) ||
- &quit("writing $status.new: $!");
- close(S) || &quit("closing $status.new: $!");
+ die "writing $status.new: $!";
+ close(S) || die "closing $status.new: $!";
if (-e $status) {
$change = 'change';
} else {
$change = 'new';
}
- rename("$status.new",$status) || &quit("installing new $status: $!");
+ rename("$status.new",$status) || die "installing new $status: $!";
}
# $disablebughook is a bit of a hack to let format migration scripts use
print STDERR "Cannot archive $param{bug} because it is not done\n" if $DEBUG;
return $cannot_archive
}
+ # Check to make sure that the bug has none of the unremovable tags set
+ if (@{$config{removal_unremovable_tags}}) {
+ for my $tag (split ' ', ($status->{tags}||'')) {
+ if (grep {$tag eq $_} @{$config{removal_unremovable_tags}}) {
+ print STDERR "Cannot archive $param{bug} because it has an unremovable tag '$tag'\n" if $DEBUG;
+ return $cannot_archive;
+ }
+ }
+ }
+
# If we just are checking if the bug can be archived, we'll not even bother
# checking the versioning information if the bug has been -done for less than 28 days.
my $log_file = getbugcomponent($param{bug},'log');
last if $buggy eq 'found';
$min_fixed_time = min($time_versions{$version},$min_fixed_time);
}
- $min_archive_days = max($min_archive_days,ceil($config{remove_age} - (time - $min_fixed_time)/(60*60*24)));
+ $min_archive_days = max($min_archive_days,ceil($config{remove_age} - (time - $min_fixed_time)/(60*60*24)))
+ # if there are no versions in the archive at all, then
+ # we can archive if enough days have passed
+ if @sourceversions;
}
# If $param{ignore_time}, then we should ignore time.
if ($param{ignore_time}) {
$status{"pending"} = 'fixed' if ($tags{fixed});
- my $presence = bug_presence(map{(exists $param{$_})?($_,$param{$_}):()}
+ my $presence = bug_presence(status => \%status,
+ map{(exists $param{$_})?($_,$param{$_}):()}
qw(bug sourceversions arch dist version found fixed package)
);
if (defined $presence) {
sub bughook_archive {
my @refs = @_;
- &filelock("debbugs.trace.lock");
+ &filelock("$config{spool_dir}/debbugs.trace.lock");
&appendfile("debbugs.trace","archive ".join(',',@refs)."\n");
my %bugs = update_realtime("$config{spool_dir}/index.db.realtime",
map{($_,'REMOVE')} @refs);
sub bughook {
my ( $type, %bugs_temp ) = @_;
- &filelock("debbugs.trace.lock");
+ &filelock("$config{spool_dir}/debbugs.trace.lock");
my %bugs;
for my $bug (keys %bugs_temp) {
=head1 SYNOPSIS
-use Debbugs::Text qw(:templates);
-print fill_in_template(template => 'cgi/foo');
+ use Debbugs::Text qw(:templates);
+ print fill_in_template(template => 'cgi/foo');
=head1 DESCRIPTION
qw(padsv padav padhv padany),
qw(rv2gv refgen srefgen ref),
qw(caller require entereval),
+ qw(gmtime time sprintf prtf),
);
$safe->share('*STDERR');
$safe->share('%config');
my $tt;
if ($tt_type eq 'FILE' and
defined $tt_templates{$tt_source} and
- (stat $tt_source)[9] > $tt_templates{$tt_source}{mtime}
+ (stat $tt_source)[9] <= $tt_templates{$tt_source}{mtime}
) {
$tt = $tt_templates{$tt_source}{template};
}
}
$tt = Text::Template->new(TYPE => $tt_type,
SOURCE => $tt_source,
+ UNTAINT => 1,
);
if ($tt_type eq 'FILE') {
$tt_templates{$tt_source}{template} = $tt;
if (not defined $tt) {
die "Unable to create Text::Template for $tt_type:$tt_source";
}
- my $ret = $tt->fill_in(#(defined $param{nosafe} and $param{nosafe})?():(HASH=>$param{variables}),
- #(defined $param{nosafe} and $param{nosafe})?():(SAFE=>$safe),
- SAFE => $safe,
- #(defined $param{nosafe} and $param{nosafe})?(PACKAGE => 'main'):(),
+ my $ret = $tt->fill_in(SAFE => $safe,
defined $param{output}?(OUTPUT=>$param{output}):(),
);
if (not defined $ret) {
# [Other people have contributed to this file; their copyrights should
# go here too.]
# Copyright 2004 by Anthony Towns
-
+# Copyright 2008 by Don Armstrong <don@donarmstrong.com>
package Debbugs::User;
read_usertags(\%ut, $userid);
write_usertags(\%ut, $userid);
+=head1 USERTAG FILE FORMAT
+
+Usertags are in a file which has (roughly) RFC822 format, with stanzas
+separated by newlines. For example:
+
+ Tag: search
+ Bugs: 73671, 392392
+
+ Value: priority
+ Bug-73671: 5
+ Bug-73487: 2
+
+ Value: bugzilla
+ Bug-72341: http://bugzilla/2039471
+ Bug-1022: http://bugzilla/230941
+
+ Category: normal
+ Cat1: status
+ Cat2: debbugs.tasks
+
+ Category: debbugs.tasks
+ Hidden: yes
+ Cat1: debbugs.tasks
+
+ Cat1Options:
+ tag=quick
+ tag=medium
+ tag=arch
+ tag=not-for-me
+
+
=head1 EXPORT TAGS
=over
use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
use base qw(Exporter);
-use Debbugs::Config qw(:globals);
+use Debbugs::Config qw(:config);
use List::Util qw(min);
+use Carp;
+use IO::File;
+
BEGIN {
($VERSION) = q$Revision: 1.4 $ =~ /^Revision:\s+([^\s+])/;
$DEBUG = 0 unless defined $DEBUG;
@EXPORT = ();
- @EXPORT_OK = qw(is_valid_user open read_usertags write_usertags);
+ @EXPORT_OK = qw(is_valid_user read_usertags write_usertags);
$EXPORT_TAGS{all} = [@EXPORT_OK];
}
-# Obsolete compatability functions
-
-sub read_usertags {
- my $ut = shift;
- my $u = shift;
-
- my $user = get_user($u);
- for my $t (keys %{$user->{"tags"}}) {
- $ut->{$t} = [] unless defined $ut->{$t};
- push @{$ut->{$t}}, @{$user->{"tags"}->{$t}};
- }
-}
-
-sub write_usertags {
- my $ut = shift;
- my $u = shift;
-
- my $user = get_user($u, 1); # locked
- $user->{"tags"} = { %{$ut} };
- $user->write();
-}
#######################################################################
# Helper functions
-sub filefromemail {
- my $e = shift;
- my $l = length($e) % 7;
- return "$gSpoolDir/user/$l/" . join("",
- map { m/^[0-9a-zA-Z_+.-]$/ ? $_ : sprintf("%%%02X", ord($_)) }
- split //, $e);
-}
-
-sub read_stanza {
- my $f = shift;
- my $field = 0;
- my @res;
- while (<$f>) {
- chomp;
- last if (m/^$/);
-
- if ($field && m/^ (.*)$/) {
- $res[-1] .= "\n" . $1;
- } elsif (m/^([^:]+):(\s+(.*))?$/) {
- $field = $1;
- push @res, ($1, $3);
- }
- }
- return @res;
-}
-
-sub fmt {
- my $s = shift;
- my $n = shift;
- my $sofar = 0;
- my $res = "";
- while ($s =~ m/^([^,]*,\s*)(.*)$/ || $s =~ m/^([^,]+)()$/) {
- my $k = $1;
- $s = $2;
- unless ($sofar == 0 or $sofar + length($k) <= $n) {
- $res .= "\n ";
- $sofar = 1;
- }
- $res .= $k;
- $sofar += length($k);
- }
- return $res . $s;
-}
-
sub is_valid_user {
my $u = shift;
return ($u =~ /^[a-zA-Z0-9._+-]+[@][a-z0-9-.]{4,}$/);
# The real deal
sub get_user {
- my $ut = {};
- my $user = {
- "tags" => $ut,
- "categories" => {},
- "visible_cats" => [],
- "unknown_stanzas" => []
- };
+ return Debbugs::User->new(@_);
+}
- my $u = shift;
- my $need_lock = shift || 0;
- my $p = filefromemail($u);
+=head2 new
- my $uf;
- $user->{"filename"} = $p;
- if (not -r $p) {
- return bless $user, "Debbugs::User";
+ my $user = Debbugs::User->new('foo@bar.com',$lock);
+
+Reads the user file associated with 'foo@bar.com' and returns a
+Debbugs::User object.
+
+=cut
+
+sub new {
+ my $class = shift;
+ $class = ref($class) || $class;
+ my ($email,$need_lock) = @_;
+ $need_lock ||= 0;
+
+ my $ut = {};
+ my $self = {"tags" => $ut,
+ "categories" => {},
+ "visible_cats" => [],
+ "unknown_stanzas" => [],
+ values => {},
+ email => $email,
+ };
+ bless $self, $class;
+
+ $self->{filename} = _file_from_email($self->{email});
+ if (not -r $self->{filename}) {
+ return $self;
}
- open($uf, "< $p") or die "Unable to open file $p for reading: $!";
+ my $uf = IO::File->new($self->{filename},'r')
+ or die "Unable to open file $self->{filename} for reading: $!";
if ($need_lock) {
- flock($uf, LOCK_EX);
- $user->{"locked"} = $uf;
+ flock($uf, LOCK_EX);
+ $self->{"locked"} = $uf;
}
-
+
while(1) {
- my @stanza = read_stanza($uf);
- last if ($#stanza == -1);
+ my @stanza = _read_stanza($uf);
+ last unless @stanza;
if ($stanza[0] eq "Tag") {
my %tag = @stanza;
my $t = $tag{"Tag"};
}
$c{"ttl"} = [@ttl];
$c{"pri"} = [@pri];
- push @cat, { %c };
+ push @cat, { %c };
} else {
push @cat, $stanza{"Cat${i}"};
}
}
- $user->{"categories"}->{$catname} = [@cat];
- push @{$user->{"visible_cats"}}, $catname
- unless ($stanza{"Hidden"} || "no") eq "yes";
- } else {
- push @{$user->{"unknown_stanzas"}}, [@stanza];
+ $self->{"categories"}->{$catname} = [@cat];
+ push @{$self->{"visible_cats"}}, $catname
+ unless ($stanza{"Hidden"} || "no") eq "yes";
+ }
+ elsif ($stanza[0] eq 'Value') {
+ my ($value,$value_name,%bug_values) = @stanza;
+ while (my ($k,$v) = each %bug_values) {
+ my ($bug) = $k =~ m/^Bug-(\d+)/;
+ next unless defined $bug;
+ $self->{values}{$bug}{$value_name} = $v;
+ }
+ }
+ else {
+ push @{$self->{"unknown_stanzas"}}, [@stanza];
}
}
- close($uf) unless $need_lock;
- bless $user, "Debbugs::User";
- return $user;
+ return $self;
}
sub write {
- my $user = shift;
- my $uf;
- my $ut = $user->{"tags"};
- my $p = $user->{"filename"};
+ my $self = shift;
+
+ my $ut = $self->{"tags"};
+ my $p = $self->{"filename"};
- if ($p =~ m/^(.+)$/) { $p = $1; } else { return; }
- open $uf, "> $p" or return;
+ if (not defined $self->{filename} or not
+ length $self->{filename}) {
+ carp "Tried to write a usertag with no filename defined";
+ return;
+ }
+ my $uf = IO::File->new($self->{filename},'w');
+ if (not $uf) {
+ carp "Unable to open $self->{filename} for writing: $!";
+ return;
+ }
- for my $us (@{$user->{"unknown_stanzas"}}) {
+ for my $us (@{$self->{"unknown_stanzas"}}) {
my @us = @{$us};
- while (@us) {
- my $k = shift @us; my $v = shift @us;
+ while (my ($k,$v) = splice (@us,0,2)) {
$v =~ s/\n/\n /g;
- print $uf "$k: $v\n";
- }
- print $uf "\n";
+ print {$uf} "$k: $v\n";
+ }
+ print {$uf} "\n";
}
for my $t (keys %{$ut}) {
next if @{$ut->{$t}} == 0;
- print $uf "Tag: $t\n";
- print $uf fmt("Bugs: " . join(", ", @{$ut->{$t}}), 77) . "\n";
+ print {$uf} "Tag: $t\n";
+ print {$uf} _wrap_to_length("Bugs: " . join(", ", @{$ut->{$t}}), 77) . "\n";
print $uf "\n";
}
- my $uc = $user->{"categories"};
- my %vis = map { $_, 1 } @{$user->{"visible_cats"}};
+ my $uc = $self->{"categories"};
+ my %vis = map { $_, 1 } @{$self->{"visible_cats"}};
for my $c (keys %{$uc}) {
next if @{$uc->{$c}} == 0;
}
print $uf "\n";
}
+ # handle the value stanzas
+ my %value;
+ # invert the bug->value hash slightly
+ for my $bug (keys %{$self->{values}}) {
+ for my $value (keys %{$self->{values}{$bug}}) {
+ $value{$value}{$bug} = $self->{values}{$bug}{$value}
+ }
+ }
+ for my $value (keys %value) {
+ print {$uf} "Value: $value\n";
+ for my $bug (keys %{$value{$value}}) {
+ my $bug_value = $value{$value}{$bug};
+ $bug_value =~ s/\n/\n /g;
+ print {$uf} "Bug-$bug: $bug_value\n";
+ }
+ print {$uf} "\n";
+ }
close($uf);
- delete $user->{"locked"};
+ delete $self->{"locked"};
+}
+
+=head1 OBSOLETE FUNCTIONS
+
+=cut
+
+=head2 read_usertags
+
+ read_usertags($usertags,$email)
+
+
+=cut
+
+sub read_usertags {
+ my ($usertags,$email) = @_;
+
+ carp "read_usertags is deprecated";
+ my $user = get_user($email);
+ for my $tag (keys %{$user->{"tags"}}) {
+ $usertags->{$tag} = [] unless defined $usertags->{$tag};
+ push @{$usertags->{$tag}}, @{$user->{"tags"}->{$tag}};
+ }
+ return $usertags;
+}
+
+=head2 write_usertags
+
+ write_usertags($usertags,$email);
+
+Gets a lock on the usertags, applies the usertags passed, and writes
+them out.
+
+=cut
+
+sub write_usertags {
+ my ($usertags,$email) = @_;
+
+ carp "write_usertags is deprecated";
+ my $user = Debbugs::User->new($email,1); # locked
+ $user->{"tags"} = { %{$usertags} };
+ $user->write();
+}
+
+
+=head1 PRIVATE FUNCTIONS
+
+=head2 _file_from_email
+
+ my $filename = _file_from_email($email)
+
+Turns an email into the filename where the usertag can be located.
+
+=cut
+
+sub _file_from_email {
+ my ($email) = @_;
+ my $email_length = length($email) % 7;
+ my $escaped_email = $email;
+ $escaped_email =~ s/([^0-9a-zA-Z_+.-])/sprintf("%%%02X", ord($1))/eg;
+ return "$config{usertag_dir}/$email_length/$escaped_email";
+}
+
+=head2 _read_stanza
+
+ my @stanza = _read_stanza($fh);
+
+Reads a single stanza from a filehandle and returns it
+
+=cut
+
+sub _read_stanza {
+ my ($file_handle) = @_;
+ my $field = 0;
+ my @res;
+ while (<$file_handle>) {
+ chomp;
+ last if (m/^$/);
+ if ($field && m/^ (.*)$/) {
+ $res[-1] .= "\n" . $1;
+ } elsif (m/^([^:]+):(\s+(.*))?$/) {
+ $field = $1;
+ push @res, ($1, $3||'');
+ }
+ }
+ return @res;
}
+
+=head2 _wrap_to_length
+
+ _wrap_to_length
+
+Wraps a line to a specific length by splitting at commas
+
+=cut
+
+sub _wrap_to_length {
+ my ($content,$line_length) = @_;
+ my $current_line_length;
+ my $result = "";
+ while ($content =~ m/^([^,]*,\s*)(.*)$/ || $content =~ m/^([^,]+)()$/) {
+ my $current_word = $1;
+ $content = $2;
+ if ($current_line_length != 0 and
+ $current_line_length + length($current_word) <= $line_length) {
+ $result .= "\n ";
+ $current_line_length = 1;
+ }
+ $result .= $current_word;
+ $current_line_length += length($current_word);
+ }
+ return $result . $content;
+}
+
+
+
+
1;
__END__
package Debbugs::Versions;
+use warnings;
+
use strict;
=head1 NAME
=cut
-sub new ($$)
+sub new
{
my $this = shift;
my $class = ref($this) || $this;
=cut
-sub isancestor ($$$)
+sub isancestor
{
my $self = shift;
my $ancestor = shift;
=cut
-sub leaves ($)
+sub leaves
{
my $self = shift;
=cut
-sub merge ($@)
+sub merge
{
my $self = shift;
return unless @_;
=cut
-sub load ($*)
+sub load
{
my $self = shift;
my $fh = shift;
=cut
-sub save ($*)
+sub save
{
my $self = shift;
my $fh = shift;
=cut
-sub buggy ($$$$)
+sub buggy
{
my $self = shift;
my $version = shift;
=cut
-sub allstates ($$$;$)
+sub allstates
{
my $self = shift;
my $found = shift;
man8_dir := $(man_dir)/man8
examples_dir := $(doc_dir)/examples
-scripts_in := $(filter-out scripts/config.in scripts/errorlib.in scripts/text.in, $(wildcard scripts/*.in))
+scripts_in := $(filter-out scripts/config scripts/errorlib scripts/text, $(wildcard scripts/*))
htmls_in := $(wildcard html/*.html.in)
cgis := $(wildcard cgi/*.cgi cgi/*.pl)
# install the scripts
- $(foreach script,$(scripts_in), $(install_exec) $(script) $(scripts_dir)/$(patsubst scripts/%.in,%,$(script));)
- $(install_data) scripts/errorlib.in $(scripts_dir)/errorlib
+ $(foreach script,$(scripts_in), $(install_exec) $(script) $(scripts_dir)/$(script);)
+ $(install_data) scripts/errorlib $(scripts_dir)/errorlib
# install examples
- $(install_data) scripts/config.in $(examples_dir)/config
+ $(install_data) scripts/config $(examples_dir)/config
$(install_data) scripts/config.debian $(examples_dir)/config.debian
- $(install_data) scripts/text.in $(examples_dir)/text
+ $(install_data) scripts/text $(examples_dir)/text
$(install_data) debian/crontab misc/nextnumber misc/Maintainers \
misc/Maintainers.override misc/pseudo-packages.description \
misc/sources $(examples_dir)
# install the CGIs
for cgi in $(cgis); do $(install_exec) $$cgi $(var_dir)/www/cgi; done
- $(install_exec) cgi/bugs-fetch2.pl.in $(var_dir)/www/cgi/bugs-fetch2.pl
+ $(install_exec) cgi/bugs-fetch2.pl $(var_dir)/www/cgi/bugs-fetch2.pl
# # install Perl modules
# for perl in $(perls); do $(install_data) $$perl $(perl_dir); done
use warnings;
use strict;
-use POSIX qw(strftime tzset);
+
+use POSIX qw(strftime);
use MIME::Parser;
use MIME::Decoder;
use IO::Scalar;
# for read_log_records
use Debbugs::Log qw(read_log_records);
-use Debbugs::MIME qw(convert_to_utf8 decode_rfc1522 create_mime_message);
use Debbugs::CGI qw(:url :html :util);
+use Debbugs::CGI::Bugreport qw(:all);
use Debbugs::Common qw(buglog getmaintainers);
use Debbugs::Packages qw(getpkgsrc);
use Debbugs::Status qw(splitpackages get_bug_status isstrongseverity);
use Scalar::Util qw(looks_like_number);
+
+use Debbugs::Text qw(:templates);
+
use CGI::Simple;
my $q = new CGI::Simple;
qw(mboxstat mboxmaint archive),
qw(repeatmerged)
],
- default => {msg => '',
+ default => {# msg => '',
boring => 'no',
terse => 'no',
reverse => 'no',
);
# This is craptacular.
-my $tail_html;
-
my $ref = $param{bug} or quitcgi("No bug number");
$ref =~ /(\d+)/ or quitcgi("Invalid bug number");
$ref = $1;
my $short = "#$ref";
-my $msg = $param{'msg'};
-my $att = $param{'att'};
+my ($msg) = $param{msg} =~ /^(\d+)$/ if exists $param{msg};
+my ($att) = $param{att} =~ /^(\d+)$/ if exists $param{att};
my $boring = $param{'boring'} eq 'yes';
my $terse = $param{'terse'} eq 'yes';
my $reverse = $param{'reverse'} eq 'yes';
my $mbox = $param{'mbox'} eq 'yes';
my $mime = $param{'mime'} eq 'yes';
-my $trim_headers = ($param{trim} || ($msg?'no':'yes')) eq 'yes';
+my $trim_headers = ($param{trim} || ((defined $msg and $msg)?'no':'yes')) eq 'yes';
my $mbox_status_message = $param{mboxstat} eq 'yes';
my $mbox_maint = $param{mboxmaint} eq 'yes';
my $repeatmerged = $param{'repeatmerged'} eq 'yes';
my $buglog = buglog($ref);
-
-if (defined $ENV{REQUEST_METHOD} and $ENV{REQUEST_METHOD} eq 'HEAD' and not defined($att) and not $mbox) {
- print "Content-Type: text/html; charset=utf-8\n";
- my @stat = stat $buglog;
- if (@stat) {
- my $mtime = strftime '%a, %d %b %Y %T GMT', gmtime($stat[9]);
- print "Last-Modified: $mtime\n";
- }
- print "\n";
- exit 0;
-}
-
-sub display_entity ($$$$\$\@);
-sub display_entity ($$$$\$\@) {
- my $entity = shift;
- my $ref = shift;
- my $top = shift;
- my $xmessage = shift;
- my $this = shift;
- my $attachments = shift;
-
- my $head = $entity->head;
- my $disposition = $head->mime_attr('content-disposition');
- $disposition = 'inline' if not defined $disposition or $disposition eq '';
- my $type = $entity->effective_type;
- my $filename = $entity->head->recommended_filename;
- $filename = '' unless defined $filename;
- $filename = decode_rfc1522($filename);
-
- if ($top and not $terse) {
- my $header = $entity->head;
- $$this .= "<pre class=\"headers\">\n";
- if ($trim_headers) {
- my @headers;
- foreach (qw(From To Cc Subject Date)) {
- my $head_field = $head->get($_);
- next unless defined $head_field and $head_field ne '';
- push @headers, qq(<b>$_:</b> ) . html_escape(decode_rfc1522($head_field));
- }
- $$this .= join(qq(), @headers) unless $terse;
- } else {
- $$this .= html_escape(decode_rfc1522($entity->head->stringify));
- }
- $$this .= "</pre>\n";
- }
-
- unless (($top and $type =~ m[^text(?:/plain)?(?:;|$)]) or
- ($type =~ m[^multipart/])) {
- push @$attachments, $entity;
- my @dlargs = ($ref, msg=>$xmessage, att=>$#$attachments);
- push @dlargs, (filename=>$filename) if $filename ne '';
- my $printname = $filename;
- $printname = 'Message part ' . ($#$attachments + 1) if $filename eq '';
- $$this .= '<pre class="mime">[<a href="' . html_escape(bug_url(@dlargs)) . qq{">$printname</a> } .
- "($type, $disposition)]</pre>\n";
-
- if ($msg and defined($att) and $att == $#$attachments) {
- my $head = $entity->head;
- chomp(my $type = $entity->effective_type);
- my $body = $entity->stringify_body;
- print "Content-Type: $type";
- my ($charset) = $head->get('Content-Type:') =~ m/charset\s*=\s*\"?([\w-]+)\"?/i;
- print qq(; charset="$charset") if defined $charset;
- print "\n";
- if ($filename ne '') {
- my $qf = $filename;
- $qf =~ s/"/\\"/g;
- $qf =~ s[.*/][];
- print qq{Content-Disposition: inline; filename="$qf"\n};
- }
- print "\n";
- my $decoder = new MIME::Decoder($head->mime_encoding);
- $decoder->decode(new IO::Scalar(\$body), \*STDOUT);
- exit(0);
- }
- }
-
- return if not $top and $disposition eq 'attachment' and not defined($att);
- return unless ($type =~ m[^text/?] and
- $type !~ m[^text/(?:html|enriched)(?:;|$)]) or
- $type =~ m[^application/pgp(?:;|$)] or
- $entity->parts;
-
- if ($entity->is_multipart) {
- my @parts = $entity->parts;
- foreach my $part (@parts) {
- display_entity($part, $ref, 0, $xmessage,
- $$this, @$attachments);
- $$this .= "\n";
- }
- } elsif ($entity->parts) {
- # We must be dealing with a nested message.
- $$this .= "<blockquote>\n";
- my @parts = $entity->parts;
- foreach my $part (@parts) {
- display_entity($part, $ref, 1, $xmessage,
- $$this, @$attachments);
- $$this .= "\n";
- }
- $$this .= "</blockquote>\n";
- } else {
- if (not $terse) {
- my $content_type = $entity->head->get('Content-Type:') || "text/html";
- my ($charset) = $content_type =~ m/charset\s*=\s*\"?([\w-]+)\"?/i;
- my $body = $entity->bodyhandle->as_string;
- $body = convert_to_utf8($body,$charset) if defined $charset;
- $body = html_escape($body);
- # 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.
- }
- # Add links to URLs
- $body =~ s,((ftp|http|https)://[\S~-]+?/?)((\>\;)?[)]?[']?[:.\,]?(\s|$)),<a href=\"$1\">$1</a>$3,go;
- # Add links to bug closures
- $body =~ s[(closes:\s*(?:bug)?\#?\s?\d+(?:,?\s*(?:bug)?\#?\s?\d+)*)
- ][my $temp = $1; $temp =~ s{(\d+)}{qq(<a href=").html_escape(bug_url($1)).qq(">$1</a>)}ge; $temp;]gxie;
- $$this .= qq(<pre class="message">$body</pre>\n);
- }
- }
-}
-
-my %maintainer = %{getmaintainers()};
-my %pkgsrc = %{getpkgsrc()};
-
-my $indexentry;
-my $showseverity;
-
-my $tpack;
-my $tmain;
-
-my $dtime = strftime "%a, %e %b %Y %T UTC", gmtime;
-$tail_html = $gHTMLTail;
-$tail_html =~ s/SUBSTITUTE_DTIME/$dtime/;
-
-my %status = %{get_bug_status(bug=>$ref)};
-unless (%status) {
- print <<EOF;
-Content-Type: text/html; charset=utf-8
-
-<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
-<html>
-<head><title>$short - $gProject $gBug report logs</title></head>
-<body>
-<h1>$gProject $gBug report logs - $short</h1>
-<p>There is no record of $gBug $short.
-Try the <a href="http://$gWebDomain/">search page</a> instead.</p>
-$tail_html</body></html>
-EOF
- exit 0;
-}
-
-$|=1;
-
-$tpack = lc $status{'package'};
-my @tpacks = splitpackages($tpack);
-
-if ($status{severity} eq 'normal') {
- $showseverity = '';
-} elsif (isstrongseverity($status{severity})) {
- $showseverity = "Severity: <em class=\"severity\">$status{severity}</em>;\n";
-} else {
- $showseverity = "Severity: $status{severity};\n";
-}
-
-if (@{$status{found_versions}} or @{$status{fixed_versions}}) {
- $indexentry.= q(<div style="float:right"><a href=").
- html_escape(version_url($status{package},
- $status{found_versions},
- $status{fixed_versions},
- )).
- q("><img alt="version graph" src=").
- html_escape(version_url($status{package},
- $status{found_versions},
- $status{fixed_versions},
- 2,
- 2,
- )).qq{"></a></div>};
-}
-
-
-$indexentry .= "<div class=\"msgreceived\">\n";
-$indexentry .= htmlize_packagelinks($status{package}, 0) . ";\n";
-
-foreach my $pkg (@tpacks) {
- my $tmaint = defined($maintainer{$pkg}) ? $maintainer{$pkg} : '(unknown)';
- my $tsrc = defined($pkgsrc{$pkg}) ? $pkgsrc{$pkg} : '(unknown)';
-
- $indexentry .=
- htmlize_maintlinks(sub { $_[0] == 1 ? "Maintainer for $pkg is\n"
- : "Maintainers for $pkg are\n" },
- $tmaint);
- $indexentry .= ";\nSource for $pkg is\n".
- '<a href="'.html_escape(pkg_url(src=>$tsrc))."\">$tsrc</a>" if ($tsrc ne "(unknown)");
- $indexentry .= ".\n";
-}
-
-$indexentry .= "<br>";
-$indexentry .= htmlize_addresslinks("Reported by: ", \&submitterurl,
- $status{originator}) . ";\n";
-$indexentry .= sprintf "Date: %s.\n",
- (strftime "%a, %e %b %Y %T UTC", localtime($status{date}));
-
-$indexentry .= "<br>Owned by: " . html_escape($status{owner}) . ".\n"
- if length $status{owner};
-
-$indexentry .= "</div>\n";
-
-my @descstates;
-
-$indexentry .= "<h3>$showseverity";
-$indexentry .= sprintf "Tags: %s;\n",
- html_escape(join(", ", sort(split(/\s+/, $status{tags}))))
- if length($status{tags});
-$indexentry .= "<br>" if (length($showseverity) or length($status{tags}));
-
-my @merged= split(/ /,$status{mergedwith});
-if (@merged) {
- my $descmerged = 'Merged with ';
- my $mseparator = '';
- for my $m (@merged) {
- $descmerged .= $mseparator."<a href=\"" . html_escape(bug_url($m)) . "\">#$m</a>";
- $mseparator= ",\n";
- }
- push @descstates, $descmerged;
-}
-
-if (@{$status{found_versions}}) {
- my $foundtext = 'Found in ';
- $foundtext .= (@{$status{found_versions}} == 1) ? 'version ' : 'versions ';
- $foundtext .= join ', ', map html_escape($_), @{$status{found_versions}};
- push @descstates, $foundtext;
-}
-if (@{$status{fixed_versions}}) {
- my $fixedtext = '<strong>Fixed</strong> in ';
- $fixedtext .= (@{$status{fixed_versions}} == 1) ? 'version ' : 'versions ';
- $fixedtext .= join ', ', map html_escape($_), @{$status{fixed_versions}};
- if (length($status{done})) {
- $fixedtext .= ' by ' . html_escape(decode_rfc1522($status{done}));
- }
- push @descstates, $fixedtext;
-}
-
-if (@{$status{found_versions}} or @{$status{fixed_versions}}) {
- push @descstates, '<a href="'.
- html_escape(version_url($status{package},
- $status{found_versions},
- $status{fixed_versions},
- )).qq{">Version Graph</a>};
-}
-
-if (length($status{done})) {
- push @descstates, "<strong>Done:</strong> ".html_escape(decode_rfc1522($status{done}));
-}
-
-if (length($status{forwarded})) {
- my $forward_link = html_escape($status{forwarded});
- $forward_link =~ s,((ftp|http|https)://[\S~-]+?/?)((\>\;)?[)]?[']?[:.\,]?(\s|$)),<a href="$1">$1</a>$3,go;
- push @descstates, "<strong>Forwarded</strong> to $forward_link";
-}
-
-
-my @blockedby= split(/ /, $status{blockedby});
-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};
- push @descstates, "Fix blocked by <a href=\"" . html_escape(bug_url($b)) . "\">#$b</a>: ".html_escape($s{subject});
- }
-}
-
-my @blocks= split(/ /, $status{blocks});
-if (@blocks && $status{"pending"} ne 'fixed' && ! length($status{done})) {
- for my $b (@blocks) {
- my %s = %{get_bug_status($b)};
- next if $s{"pending"} eq 'fixed' || length $s{done};
- push @descstates, "Blocking fix for <a href=\"" . html_escape(bug_url($b)) . "\">#$b</a>: ".html_escape($s{subject});
- }
+my @stat = stat $buglog;
+my $mtime = '';
+if (@stat) {
+ $mtime = strftime '%a, %d %b %Y %T GMT', gmtime($stat[9]);
}
-if ($buglog !~ m#^\Q$gSpoolDir/db#) {
- push @descstates, "Bug is archived. No further changes may be made";
+if ($q->request_method() eq 'HEAD' and not defined($att) and not $mbox) {
+ print $q->header(-type => "text/html",
+ -charset => 'utf-8',
+ (length $mtime)?(-last_modified => $mtime):(),
+ );
+ exit 0;
}
-$indexentry .= join(";\n<br>", @descstates) . ".\n" if @descstates;
-$indexentry .= "</h3>\n";
-
-my $descriptivehead = $indexentry;
my $buglogfh;
if ($buglog =~ m/\.gz$/) {
my $oldpath = $ENV{'PATH'};
$ENV{'PATH'} = '/bin:/usr/bin';
- $buglogfh = new IO::File "zcat $buglog |" or &quitcgi("open log for $ref: $!");
+ $buglogfh = IO::File->new("zcat $buglog |") or quitcgi("open log for $ref: $!");
$ENV{'PATH'} = $oldpath;
} else {
- $buglogfh = new IO::File "<$buglog" or &quitcgi("open log for $ref: $!");
+ $buglogfh = IO::File->new($buglog,'r') or quitcgi("open log for $ref: $!");
}
+my %status = %{get_bug_status(bug=>$ref)};
+
my @records;
eval{
@records = read_log_records($buglogfh);
}
undef $buglogfh;
-=head2 handle_email_message
-
- handle_email_message($record->{text},
- ref => $bug_number,
- msg_number => $msg_number,
- );
-
-Returns a decoded e-mail message and displays entities/attachments as
-appropriate.
-
-
-=cut
-
-sub handle_email_message{
- my ($email,%options) = @_;
-
- my $output = '';
- my $parser = new MIME::Parser;
- # Because we are using memory, not tempfiles, there's no need to
- # clean up here like in Debbugs::MIME
- $parser->tmp_to_core(1);
- $parser->output_to_core(1);
- my $entity = $parser->parse_data( $email);
- my @attachments = ();
- display_entity($entity, $options{ref}, 1, $options{msg_number}, $output, @attachments);
- return $output;
-
-}
-
-=head2 handle_record
-
- push @log, handle_record($record,$ref,$msg_num);
-
-Deals with a record in a bug log as returned by
-L<Debbugs::Log::read_log_records>; returns the log information that
-should be output to the browser.
-
-=cut
-
-sub handle_record{
- my ($record,$bug_number,$msg_number,$seen_msg_ids) = @_;
-
- my $output = '';
- local $_ = $record->{type};
- if (/html/) {
- my ($time) = $record->{text} =~ /<!--\s+time:(\d+)\s+-->/;
- my $class = $record->{text} =~ /^<strong>(?:Acknowledgement|Reply|Information|Report|Notification)/ ? 'infmessage':'msgreceived';
- $output .= decode_rfc1522($record->{text});
- # Link to forwarded http:// urls in the midst of the report
- # (even though these links already exist at the top)
- $output =~ s,((?:ftp|http|https)://[\S~-]+?/?)([\)\'\:\.\,]?(?:\s|\.<|$)),<a href=\"$1\">$1</a>$2,go;
- # Add links to the cloned bugs
- $output =~ s{(Bug )(\d+)( cloned as bugs? )(\d+)(?:\-(\d+)|)}{$1.bug_links($2).$3.bug_links($4,$5)}eo;
- # Add links to merged bugs
- $output =~ s{(?<=Merged )([\d\s]+)(?=\.)}{join(' ',map {bug_links($_)} (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($2):'').$3.
- join(' ',map {bug_links($_)} (split /\,?\s+/, $4))}eo;
- # Add links to reassigned packages
- $output =~ s{(Bug reassigned from package \`)([^']+?)((?:'|\&\#39;) to \`)([^']+?)((?:'|\&\#39;))}
- {$1.q(<a href=").html_escape(pkg_url(pkg=>$2)).qq(">$2</a>).$3.q(<a href=").html_escape(pkg_url(pkg=>$4)).qq(">$4</a>).$5}eo;
- if (defined $time) {
- $output .= ' ('.strftime('%a, %d %b %Y %T GMT',gmtime($time)).') ';
- }
- $output .= '<a href="' . html_escape(bug_url($ref, msg => ($msg_number+1))) . '">Full text</a> and <a href="' .
- html_escape(bug_url($ref, msg => ($msg_number+1), mbox => 'yes')) . '">rfc822 format</a> available.';
-
- $output = qq(<div class="$class"><hr>\n<a name="$msg_number"></a>\n) . $output . "</div>\n";
- }
- elsif (/recips/) {
- my ($msg_id) = $record->{text} =~ /^Message-Id:\s+<(.+)>/im;
- if (defined $msg_id and exists $$seen_msg_ids{$msg_id}) {
- return ();
- }
- elsif (defined $msg_id) {
- $$seen_msg_ids{$msg_id} = 1;
- }
- $output .= qq(<hr><p class="msgreceived"><a name="$msg_number"></a>\n);
- $output .= 'View this message in <a href="' . html_escape(bug_url($ref, msg=>$msg_number, mbox=>'yes')) . '">rfc822 format</a></p>';
- $output .= handle_email_message($record->{text},
- ref => $bug_number,
- msg_number => $msg_number,
- );
- }
- elsif (/autocheck/) {
- # Do nothing
- }
- elsif (/incoming-recv/) {
- my ($msg_id) = $record->{text} =~ /^Message-Id:\s+<(.+)>/im;
- if (defined $msg_id and exists $$seen_msg_ids{$msg_id}) {
- return ();
- }
- elsif (defined $msg_id) {
- $$seen_msg_ids{$msg_id} = 1;
- }
- # Incomming Mail Message
- my ($received,$hostname) = $record->{text} =~ m/Received: \(at (\S+)\) by (\S+)\;/;
- $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 |.
- html_escape("$received\@$hostname") .
- q| (<a href="| . html_escape(bug_url($ref, msg=>$msg_number)) . '">full text</a>'.
- q|, <a href="| . html_escape(bug_url($ref, msg=>$msg_number,mbox=>'yes')) .'">mbox</a>)'.":</p>\n";
- $output .= handle_email_message($record->{text},
- ref => $bug_number,
- msg_number => $msg_number,
- );
- }
- else {
- die "Unknown record type $_";
- }
- return $output;
-}
my $log='';
my $msg_num = 0;
my $skip_next = 0;
-if (looks_like_number($msg) and ($msg-1) <= $#records) {
+if (defined($msg) and ($msg-1) <= $#records) {
@records = ($records[$msg-1]);
$msg_num = $msg - 1;
}
}
else {
+ if (defined $att and defined $msg and @records) {
+ $msg_num++;
+ print handle_email_message($records[0]->{text},
+ ref => $ref,
+ msg_num => $msg_num,
+ att => $att,
+ msg => $msg,
+ );
+ exit 0;
+ }
my %seen_msg_ids;
for my $record (@records) {
$msg_num++;
$log = join("\n",@log);
-print "Content-Type: text/html; charset=utf-8\n";
+# All of the below should be turned into a template
-my @stat = stat $buglog;
-if (@stat) {
- my $mtime = strftime '%a, %d %b %Y %T GMT', gmtime($stat[9]);
- print "Last-Modified: $mtime\n";
+my %maintainer = %{getmaintainers()};
+my %pkgsrc = %{getpkgsrc()};
+
+my $indexentry;
+my $showseverity;
+
+my $tpack;
+my $tmain;
+
+my $dtime = strftime "%a, %e %b %Y %T UTC", gmtime;
+
+unless (%status) {
+ print $q->header(-type => "text/html",
+ -charset => 'utf-8',
+ (length $mtime)?(-last_modified => $mtime):(),
+ );
+ print fill_in_template(template=>'cgi/no_such_bug',
+ variables => {modify_time => $dtime,
+ bug_num => $ref,
+ },
+ );
+ exit 0;
}
-print "\n";
-
-my $title = html_escape($status{subject});
-
-my $dummy2 = $gWebHostBugDir;
-
-print "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">\n";
-print <<END;
-<HTML><HEAD>
-<TITLE>$short - $title - $gProject $gBug report logs</TITLE>
-<meta http-equiv="Content-Type" content="text/html;charset=utf-8">
-<link rel="stylesheet" href="$gWebHostBugDir/css/bugs.css" type="text/css">
-<script type="text/javascript">
-<!--
-function toggle_infmessages()
-{
- allDivs=document.getElementsByTagName("div");
- for (var i = 0 ; i < allDivs.length ; i++ )
- {
- if (allDivs[i].className == "infmessage")
- {
- allDivs[i].style.display=(allDivs[i].style.display == 'none' | allDivs[i].style.display == '') ? 'block' : 'none';
- }
- }
+#$|=1;
+
+my %package;
+my @packages = splitpackages($status{package});
+
+foreach my $pkg (@packages) {
+ $package{$pkg} = {maintainer => exists($maintainer{$pkg}) ? $maintainer{$pkg} : '(unknown)',
+ source => exists($pkgsrc{$pkg}) ? $pkgsrc{$pkg} : '(unknown)',
+ package => $pkg,
+ };
}
--->
-</script>
-</HEAD>
-<BODY>
-END
-print "<H1>" . "$gProject $gBug report logs - <A HREF=\"mailto:$ref\@$gEmailDomain\">$short</A>" .
- "<BR>" . $title . "</H1>\n";
-print "$descriptivehead\n";
-if (looks_like_number($msg)) {
- printf qq(<p><a href="%s">Full log</a></p>),html_escape(bug_url($ref));
+# fixup various bits of the status
+$status{tags_array} = [sort(split(/\s+/, $status{tags}))];
+$status{date_text} = strftime('%a, %e %b %Y %T UTC', gmtime($status{date}));
+$status{mergedwith_array} = [split(/ /,$status{mergedwith})];
+
+
+my $version_graph = '';
+if (@{$status{found_versions}} or @{$status{fixed_versions}}) {
+ $version_graph = q(<a href=").
+ html_escape(version_url(package => $status{package},
+ found => $status{found_versions},
+ fixed => $status{fixed_versions},
+ )
+ ).
+ q("><img alt="version graph" src=").
+ html_escape(version_url(package => $status{package},
+ found => $status{found_versions},
+ fixed => $status{fixed_versions},
+ width => 2,
+ height => 2,
+ )
+ ).
+ qq{"></a>};
}
-else {
- print qq(<p><a href="mailto:$ref\@$gEmailDomain">Reply</a> ),
- qq(or <a href="mailto:$ref-subscribe\@$gEmailDomain">subscribe</a> ),
- qq(to this bug.</p>\n);
- print qq(<p><a href="javascript:toggle_infmessages();">Toggle useless messages</a></p>);
- printf qq(<div class="msgreceived"><p>View this report as an <a href="%s">mbox folder</a>, ).
- qq(<a href="%s">status mbox</a>, <a href="%s">maintainer mbox</a></p></div>\n),
- html_escape(bug_url($ref, mbox=>'yes')),
- html_escape(bug_url($ref, mbox=>'yes',mboxstatus=>'yes')),
- html_escape(bug_url($ref, mbox=>'yes',mboxmaint=>'yes'));
+
+
+
+my @blockedby= split(/ /, $status{blockedby});
+$status{blockedby_array} = [];
+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};
+ push @{$status{blockedby_array}},{bug_num => $b, subject => $s{subject}, status => \%s};
+ }
}
-print "$log";
-print "<HR>";
-print "<p class=\"msgreceived\">Send a report that <a href=\"/cgi-bin/bugspam.cgi?bug=$ref\">this bug log contains spam</a>.</p>\n<HR>\n";
-print $tail_html;
-print "</BODY></HTML>\n";
+my @blocks= split(/ /, $status{blocks});
+$status{blocks_array} = [];
+if (@blocks && $status{"pending"} ne 'fixed' && ! length($status{done})) {
+ for my $b (@blocks) {
+ my %s = %{get_bug_status($b)};
+ next if $s{"pending"} eq 'fixed' || length $s{done};
+ push @{$status{blocks_array}}, {bug_num => $b, subject => $s{subject}, status => \%s};
+ }
+}
+
+if ($buglog !~ m#^\Q$gSpoolDir/db#) {
+ $status{archived} = 1;
+}
+
+my $descriptivehead = $indexentry;
-exit 0;
+print $q->header(-type => "text/html",
+ -charset => 'utf-8',
+ (length $mtime)?(-last_modified => $mtime):(),
+ );
+
+print fill_in_template(template => 'cgi/bugreport',
+ variables => {status => \%status,
+ package => \%package,
+ log => $log,
+ bug_num => $ref,
+ version_graph => $version_graph,
+ isstrongseverity => \&Debbugs::Status::isstrongseverity,
+ html_escape => \&Debbugs::CGI::html_escape,
+ looks_like_number => \&Scalar::Util::looks_like_number,
+ },
+ hole_var => {'&package_links' => \&Debbugs::CGI::package_links,
+ '&bug_links' => \&Debbugs::CGI::bug_links,
+ '&version_url' => \&Debbugs::CGI::version_url,
+ '&bug_url' => \&Debbugs::CGI::bug_url,
+ '&strftime' => \&POSIX::strftime,
+ }
+ );
+++ /dev/null
-html {
- color: #000;
- background: #fefefe;
- font-family: serif;
- margin: 1em;
- border: 0;
- padding: 0;
- line-height: 120%;
-}
-
-body {
- margin: 0;
- border: 0;
- padding: 0;
-}
-
-h1, h2, h3 {
- text-align: left;
- font-family: sans-serif;
-}
-
-h1 {
- font-size: 150%;
- line-height: 150%;
-}
-
-h2 {
- font-size: 130%;
-}
-
-h3 {
- font-size: 100%;
-}
-
-a:link {
- color: #1b56ce;
- font-weight: bold;
-}
-
-a:visited {
- color:#1b56ce;
-}
-
-a:link:active, a:link:visited {
- color:#ff0000;
-}
-
-a:link:hover, a:visited:hover {
- color: #d81e1e;
-}
-
-a.submitter:link {
- color: #242424;
- font-family: sans-serif;
- font-size: 95%;
- text-decoration: underline;
- font-weight: normal;
-}
-
-a.submitter:visited, a.submitter:active {
- color: #6e6e6e;
- font-family: sans-serif;
- font-size: 95%;
-}
-
-a.submitter:hover, a.submitter:visited:hover {
- color: #d01414;
- font-family: sans-serif;
- font-size: 95%;
-}
-
-pre.message {
- font-family: monospace;
- padding-top: 0;
- margin-top: 0;
- border-top: 0;
-}
-
-.sparse li {
- padding-top: 1ex;
- margin-top: 1ex;
- border-top: 1ex;
-}
-
-a.bugtitle {
- font-weight: bold;
- font-size: 110%;
-}
-
-
-pre.headers {
- font-family: sans-serif;
- font-size: 95%;
- color: #3c3c3c;
- background-color: #f0f0f0;
- padding: 2px;
- border: #a7a7a7 1px solid;
- line-height: 120%
-}
-
-pre.mime {
- font-family: monospace;
- font-size: 95%;
- color: #797979;
-}
-
-/* This must be separate from the other CSS to make the showing of
- unimportant messages work in bugreport.cgi. */
-.infmessage { display: none; }
-
-.infmessage {
- font-family: sans-serif;
- font-size: 90%;
- color: #686868;
-}
-
-.msgreceived {
- font-family: sans-serif;
- font-size: 90%;
- color: #686868;
-}
-
-pre.tags {
- color: #a3a3a3;
- font-size: 90%;
-}
-
-hr.thin {
- color: #a1a1a1;
-}
-
-em.severity {
- color: #c31212;
-}
-
-code, address {
- font-family: sans-serif;
-}
-
-p {
- font-family: sans-serif;
- font-size: 95%;
-}
-
-h2.outstanding {
- font-family: sans-serif;
- background-color: #f0f0f0;
- color: #3c3c3c;
- border: #a7a7a7 1px solid;
- padding: 10px;
-}
-
-a.options:link, a.options:visited {
- font-family: sans-serif;
- background-color: #f0f0f0;
- color: #3c3c3c;
- text-decoration: none;
- border-bottom: #3c3c3c 1px dotted;
-}
-
-li {
- list-style-type: square;
-}
-
-.bugs li {
- margin-top: 5px;
-}
-
-input {
- border: #000 1px solid;
- margin: 3px;
-}
-
-table.forms {
- font-size: 95%;
- font-family: sans-serif;
- margin-left: 10px;
-}
-
-select {
- margin: 3px;
- border: #000 1px solid;
-}
-
# Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
-package debbugs;
-
use warnings;
use strict;
+
use POSIX qw(strftime nice);
use Debbugs::Config qw(:globals :text :config);
+
use Debbugs::User;
-use Debbugs::CGI qw(version_url maint_decode);
-use Debbugs::Common qw(getparsedaddrs :date make_list getmaintainers getpseudodesc);
+
+use Debbugs::Common qw(getparsedaddrs make_list getmaintainers getpseudodesc);
+
use Debbugs::Bugs qw(get_bugs bug_filter newest_bug);
use Debbugs::Packages qw(getsrcpkgs getpkgsrc get_versions);
-use Debbugs::Status qw(:status);
-use Debbugs::CGI qw(:all);
-use vars qw($gPackagePages $gWebDomain %gSeverityDisplay @gSeverityList);
+use Debbugs::CGI qw(:all);
-if (defined $ENV{REQUEST_METHOD} and $ENV{REQUEST_METHOD} eq 'HEAD') {
- print "Content-Type: text/html; charset=utf-8\n\n";
- exit 0;
-}
+use Debbugs::CGI::Pkgreport qw(:all);
-nice(5);
+use Debbugs::Text qw(:templates);
use CGI::Simple;
my $q = new CGI::Simple;
+if ($q->request_method() eq 'HEAD') {
+ print $q->header(-type => "text/html",
+ -charset => 'utf-8',
+ );
+ exit 0;
+}
+
+my $default_params = {ordering => 'normal',
+ archive => 0,
+ repeatmerged => 0,
+ include => [],
+ exclude => [],
+ };
+
our %param = cgi_parameters(query => $q,
single => [qw(ordering archive repeatmerged),
qw(bug-rev pend-rev sev-rev),
qw(maxdays mindays version),
qw(data which dist newest),
],
- default => {ordering => 'normal',
- archive => 0,
- repeatmerged => 1,
- },
+ default => $default_params,
);
+my ($form_options,$param) = ({},undef);
+($form_options,$param)= form_options_and_normal_param(\%param)
+ if $param{form_options};
+
+%param = %{$param} if defined $param;
+
+if (exists $param{form_options} and defined $param{form_options}) {
+ delete $param{form_options};
+ delete $param{submit} if exists $param{submit};
+ for my $default (keys %{$default_params}) {
+ if (exists $param{$default} and
+ not ref($default_params->{$default}) and
+ $default_params->{$default} eq $param{$default}
+ ) {
+ delete $param{$default};
+ }
+ }
+ for my $incexc (qw(include exclude)) {
+ next unless exists $param{$incexc};
+ $param{$incexc} = [grep /\S\:\S/, make_list($param{$incexc})];
+ }
+ print $q->redirect(munge_url('pkgreport.cgi?',%param));
+ exit 0;
+}
+
# map from yes|no to 1|0
for my $key (qw(repeatmerged bug-rev pend-rev sev-rev)) {
if (exists $param{$key}){
}
-my $archive = ($param{'archive'} || "no") eq "yes";
my $include = $param{'&include'} || $param{'include'} || "";
my $exclude = $param{'&exclude'} || $param{'exclude'} || "";
$ordering = "raw" if $raw_sort;
$ordering = 'age' if $age_sort;
}
+$param{ordering} = $ordering;
+
our ($bug_order) = $ordering =~ /(age(?:rev)?)/;
$bug_order = '' if not defined $bug_order;
delete $param{$incexcmap->{key}};
}
+
my $maxdays = ($param{'maxdays'} || -1);
my $mindays = ($param{'mindays'} || 0);
my $version = $param{'version'} || undef;
"normal" => [ qw(status severity classification) ],
);
-my @select_key = (qw(submitter maint pkg package src usertag),
- qw(status tag maintenc owner severity newest)
- );
-
if (exists $param{which} and exists $param{data}) {
$param{$param{which}} = [exists $param{$param{which}}?(make_list($param{$param{which}})):(),
make_list($param{data}),
}
-if (not grep {exists $param{$_}} @select_key and exists $param{users}) {
+if (not grep {exists $param{$_}} keys %package_search_keys and exists $param{users}) {
$param{usertag} = [make_list($param{users})];
}
-quitcgi("You have to choose something to select by") unless grep {exists $param{$_}} @select_key;
-
if (exists $param{pkg}) {
$param{package} = $param{pkg};
delete $param{pkg};
}
}
-my $Archived = $archive ? " Archived" : "";
+quitcgi("You have to choose something to select by") unless grep {exists $param{$_}} keys %package_search_keys;
-our $this = munge_url('pkgreport.cgi?',
+
+my $Archived = $param{archive} ? " Archived" : "";
+
+my $this = munge_url('pkgreport.cgi?',
%param,
);
my %strings = ();
my $dtime = strftime "%a, %e %b %Y %T UTC", gmtime;
-my $tail_html = $debbugs::gHTMLTail;
-$tail_html = $debbugs::gHTMLTail;
+my $tail_html = $gHTMLTail;
+$tail_html = $gHTMLTail;
$tail_html =~ s/SUBSTITUTE_DTIME/$dtime/;
our %seen_users;
# walk through the keys and make the right get_bugs query.
-my @search_key_order = (package => 'in package',
- tag => 'tagged',
- severity => 'with severity',
- src => 'in source package',
- maint => 'in packages maintained by',
- submitter => 'submitted by',
- owner => 'owned by',
- status => 'with status',
- );
-my %search_keys = @search_key_order;
+my $form_option_variables = {};
+$form_option_variables->{search_key_order} = [@package_search_key_order];
# Set the title sanely and clean up parameters
my @title;
-while (my ($key,$value) = splice @search_key_order, 0, 2) {
+my @temp = @package_search_key_order;
+while (my ($key,$value) = splice @temp, 0, 2) {
next unless exists $param{$key};
my @entries = ();
$param{$key} = [map {split /\s*,\s*/} make_list($param{$key})];
@bugs = get_bugs(function =>
sub {my %d=@_;
foreach my $try (splitpackages($d{"pkg"})) {
- return 1 if !getparsedaddrs($maintainers{$try});
+ return 1 if not exists $maintainers{$try};
}
return 0;
}
else {
#yeah for magick!
@bugs = get_bugs((map {exists $param{$_}?($_,$param{$_}):()}
- keys %search_keys, 'archive'),
+ keys %package_search_keys, 'archive'),
usertags => \%ut,
);
}
$title = html_escape($title);
my @names; my @prior; my @order;
-determine_ordering();
+determine_ordering(cats => \%cats,
+ param => \%param,
+ ordering => \$ordering,
+ names => \@names,
+ prior => \@prior,
+ title => \@title,
+ order => \@order,
+ );
# strip out duplicate bugs
my %bugs;
@bugs{@bugs} = @bugs;
@bugs = keys %bugs;
-my $result = pkg_htmlizebugs(\@bugs);
+my $result = pkg_htmlizebugs(bugs => \@bugs,
+ names => \@names,
+ title => \@title,
+ order => \@order,
+ prior => \@prior,
+ ordering => $ordering,
+ bugusertags => \%bugusertags,
+ bug_rev => $bug_rev,
+ bug_order => $bug_order,
+ repeatmerged => $param{repeatmerged},
+ include => $include,
+ exclude => $exclude,
+ this => $this,
+ options => \%param,
+ );
print "Content-Type: text/html; charset=utf-8\n\n";
# output infomration about the packages
for my $package (make_list($param{package}||[])) {
- output_package_info('binary',$package);
+ print generate_package_info(binary => 1,
+ package => $package,
+ options => \%param,
+ bugs => \@bugs,
+ );
}
for my $package (make_list($param{src}||[])) {
- output_package_info('source',$package);
-}
-
-sub output_package_info{
- my ($srcorbin,$package) = @_;
-
- my %pkgsrc = %{getpkgsrc()};
- my $srcforpkg = $package;
- if ($srcorbin eq 'binary') {
- $srcforpkg = $pkgsrc{$package};
- defined $srcforpkg or $srcforpkg = $package;
- }
-
- my $showpkg = html_escape($package);
- my $maintainers = getmaintainers();
- my $maint = $maintainers->{$srcforpkg};
- if (defined $maint) {
- print '<p>';
- print htmlize_maintlinks(sub { $_[0] == 1 ? "Maintainer for $showpkg is "
- : "Maintainers for $showpkg are "
- },
- $maint);
- print ".</p>\n";
- } else {
- print "<p>No maintainer for $showpkg. Please do not report new bugs against this package.</p>\n";
- }
- my @pkgs = getsrcpkgs($srcforpkg);
- @pkgs = grep( !/^\Q$package\E$/, @pkgs );
- if ( @pkgs ) {
- @pkgs = sort @pkgs;
- if ($srcorbin eq 'binary') {
- print "<p>You may want to refer to the following packages that are part of the same source:\n";
- } else {
- print "<p>You may want to refer to the following individual bug pages:\n";
- }
- #push @pkgs, $src if ( $src && !grep(/^\Q$src\E$/, @pkgs) );
- print join( ", ", map( "<A href=\"" . html_escape(munge_url($this,package=>$_,src=>[],newest=>[])) . "\">$_</A>", @pkgs ) );
- print ".\n";
- }
- my @references;
- my $pseudodesc = getpseudodesc();
- if ($package and defined($pseudodesc) and exists($pseudodesc->{$package})) {
- push @references, "to the <a href=\"http://${debbugs::gWebDomain}/pseudo-packages${debbugs::gHTMLSuffix}\">".
- "list of other pseudo-packages</a>";
- } else {
- if ($package and defined $gPackagePages) {
- push @references, sprintf "to the <a href=\"%s\">%s package page</a>",
- html_escape("http://${debbugs::gPackagePages}/$package"), html_escape("$package");
- }
- if (defined $gSubscriptionDomain) {
- my $ptslink = $package ? $srcforpkg : $src;
- push @references, q(to the <a href="http://).html_escape("$gSubscriptionDomain/$ptslink").q(">Package Tracking System</a>);
- }
- # Only output this if the source listing is non-trivial.
- if ($srcorbin eq 'binary' and $srcforpkg) {
- push @references, sprintf "to the source package <a href=\"%s\">%s</a>'s bug page", html_escape(munge_url($this,src=>$srcforpkg,package=>[],newest=>[])), html_escape($srcforpkg);
- }
- }
- if (@references) {
- $references[$#references] = "or $references[$#references]" if @references > 1;
- print "<p>You might like to refer ", join(", ", @references), ".</p>\n";
- }
- if (defined $param{maint} || defined $param{maintenc}) {
- print "<p>If you find a bug not listed here, please\n";
- printf "<a href=\"%s\">report it</a>.</p>\n",
- html_escape("http://${debbugs::gWebDomain}/Reporting${debbugs::gHTMLSuffix}");
- }
- if (not $maint and not @bugs) {
- print "<p>There is no record of the " . html_escape($package) .
- ($srcorbin eq 'binary' ? " package" : " source package") .
- ", and no bugs have been filed against it.</p>";
- $showresult = 0;
- }
+ print generate_package_info(binary => 0,
+ package => $package,
+ options => \%param,
+ bugs => \@bugs,
+ );
}
if (exists $param{maint} or exists $param{maintenc}) {
print "different addresses.\n";
}
-my $archive_links;
-my @archive_links;
-my %archive_values = (both => 'archived and unarchived',
- 0 => 'not archived',
- 1 => 'archived',
- );
-while (my ($key,$value) = each %archive_values) {
- next if $key eq lc($param{archive});
- push @archive_links, qq(<a href=").
- html_escape(pkg_url((
- map {
- $_ eq 'archive'?():($_,$param{$_})
- } keys %param),
- archive => $key
- )).qq(">$value reports </a>);
-}
-print '<p>See the '.join (' or ',@archive_links)."</p>\n";
-
-print $result if $showresult;
+# my $archive_links;
+# my @archive_links;
+# my %archive_values = (both => 'archived and unarchived',
+# 0 => 'not archived',
+# 1 => 'archived',
+# );
+# while (my ($key,$value) = each %archive_values) {
+# next if $key eq lc($param{archive});
+
# push @archive_links, qq(<a href=").
+# html_escape(pkg_url((
+# map {
+# $_ eq 'archive'?():($_,$param{$_})
+# } keys %param),
+# archive => $key
+# )).qq(">$value reports </a>);
+# }
+
# print '<p>See the '.join (' or ',@archive_links)."</p>\n";
+
+print $result;
print pkg_javascript() . "\n";
-print "<h2 class=\"outstanding\"><a class=\"options\" href=\"javascript:toggle(1)\">Options</a></h2>\n";
-print "<div id=\"a_1\">\n";
-printf "<form action=\"%s\" method=POST>\n", myurl();
-
-print "<table class=\"forms\">\n";
-
-my ($checked_any, $checked_sui, $checked_ver) = ("", "", "");
-if (defined $dist) {
- $checked_sui = "CHECKED";
-} elsif (defined $version) {
- $checked_ver = "CHECKED";
-} else {
- $checked_any = "CHECKED";
-}
-print "<tr><td>Show bugs applicable to</td>\n";
-print " <td><input id=\"b_1_1\" name=vt value=none type=radio onchange=\"enable(1);\" $checked_any>anything</td></tr>\n";
-print "<tr><td></td>";
-print " <td><input id=\"b_1_2\" name=vt value=bysuite type=radio onchange=\"enable(1);\" $checked_sui>" . pkg_htmlselectsuite(1,2,1) . " for " . pkg_htmlselectarch(1,2,2) . "</td></tr>\n";
-
-if (defined $pkg) {
- my $v = html_escape($version) || "";
- my $pkgsane = html_escape($pkg->[0]);
- print "<tr><td></td>";
- print " <td><input id=\"b_1_3\" name=vt value=bypkg type=radio onchange=\"enable(1);\" $checked_ver>$pkgsane version <input id=\"b_1_3_1\" name=version value=\"$v\"></td></tr>\n";
-} elsif (defined $src) {
- my $v = html_escape($version) || "";
- my $srcsane = html_escape($src->[0]);
- print "<tr><td></td>";
- print " <td><input name=vt value=bysrc type=radio onchange=\"enable(1);\" $checked_ver>$srcsane version <input id=\"b_1_3_1\" name=version value=\"$v\"></td></tr>\n";
-}
-print "<tr><td> </td></tr>\n";
-
-my $includetags = html_escape(join(" ", grep { !m/^subj:/i } map {split /[\s,]+/} ref($include)?@{$include}:$include));
-my $excludetags = html_escape(join(" ", grep { !m/^subj:/i } map {split /[\s,]+/} ref($exclude)?@{$exclude}:$exclude));
-my $includesubj = html_escape(join(" ", map { s/^subj://i; $_ } grep { m/^subj:/i } map {split /[\s,]+/} ref($include)?@{$include}:$include));
-my $excludesubj = html_escape(join(" ", map { s/^subj://i; $_ } grep { m/^subj:/i } map {split /[\s,]+/} ref($exclude)?@{$exclude}:$exclude));
-my $vismindays = ($mindays == 0 ? "" : $mindays);
-my $vismaxdays = ($maxdays == -1 ? "" : $maxdays);
-
-my $sel_rmy = ($param{repeatmerged} ? " selected" : "");
-my $sel_rmn = ($param{repeatmerged} ? "" : " selected");
-my $sel_ordraw = ($ordering eq "raw" ? " selected" : "");
-my $sel_ordold = ($ordering eq "oldview" ? " selected" : "");
-my $sel_ordnor = ($ordering eq "normal" ? " selected" : "");
-my $sel_ordage = ($ordering eq "age" ? " selected" : "");
-
-my $chk_bugrev = ($bug_rev ? " checked" : "");
-my $chk_pendrev = ($pend_rev ? " checked" : "");
-my $chk_sevrev = ($sev_rev ? " checked" : "");
-
-print <<EOF;
-<tr><td>Only include bugs tagged with </td><td><input name=include value="$includetags"> or that have <input name=includesubj value="$includesubj"> in their subject</td></tr>
-<tr><td>Exclude bugs tagged with </td><td><input name=exclude value="$excludetags"> or that have <input name=excludesubj value="$excludesubj"> in their subject</td></tr>
-<tr><td>Only show bugs older than</td><td><input name=mindays value="$vismindays" size=5> days, and younger than <input name=maxdays value="$vismaxdays" size=5> days</td></tr>
-
-<tr><td> </td></tr>
-
-<tr><td>Merged bugs should be</td><td>
-<select name=repeatmerged>
-<option value=yes$sel_rmy>displayed separately</option>
-<option value=no$sel_rmn>combined</option>
-</select>
-<tr><td>Categorise bugs by</td><td>
-<select name=ordering>
-<option value=raw$sel_ordraw>bug number only</option>
-<option value=old$sel_ordold>status and severity</option>
-<option value=normal$sel_ordnor>status, severity and classification</option>
-<option value=age$sel_ordage>status, severity, classification, and age</option>
-EOF
-
-{
-my $any = 0;
-my $o = $param{"ordering"} || "";
-for my $n (keys %cats) {
- next if ($n eq "normal" || $n eq "oldview");
- next if defined $hidden{$n};
- unless ($any) {
- $any = 1;
- print "<option disabled>------</option>\n";
- }
- my @names = map { ref($_) eq "HASH" ? $_->{"nam"} : $_ } @{$cats{$n}};
- my $name;
- if (@names == 1) { $name = $names[0]; }
- else { $name = " and " . pop(@names); $name = join(", ", @names) . $name; }
+print qq(<h2 class="outstanding"><!--<a class="options" href="javascript:toggle(1)">-->Options<!--</a>--></h2>\n);
- printf "<option value=\"%s\"%s>%s</option>\n",
- $n, ($o eq $n ? " selected" : ""), $name;
-}
-}
-
-print "</select></td></tr>\n";
-
-printf "<tr><td>Order bugs by</td><td>%s</td></tr>\n",
- pkg_htmlselectyesno("pend-rev", "outstanding bugs first", "done bugs first", $pend_rev);
-printf "<tr><td></td><td>%s</td></tr>\n",
- pkg_htmlselectyesno("sev-rev", "highest severity first", "lowest severity first", $sev_rev);
-printf "<tr><td></td><td>%s</td></tr>\n",
- pkg_htmlselectyesno("bug-rev", "oldest bugs first", "newest bugs first", $bug_rev);
-
-print <<EOF;
-<tr><td> </td></tr>
-<tr><td colspan=2><input value="Reload page" type="submit"> with new settings</td></tr>
-EOF
+print option_form(template => 'cgi/pkgreport_options',
+ param => \%param,
+ form_options => $form_options,
+ variables => $form_option_variables,
+ );
-print "</table></form></div>\n";
+# print "<h2 class=\"outstanding\"><a class=\"options\" href=\"javascript:toggle(1)\">Options</a></h2>\n";
+# print "<div id=\"a_1\">\n";
+# printf "<form action=\"%s\" method=POST>\n", myurl();
+#
+# print "<table class=\"forms\">\n";
+#
+# my ($checked_any, $checked_sui, $checked_ver) = ("", "", "");
+# if (defined $dist) {
+# $checked_sui = "CHECKED";
+# } elsif (defined $version) {
+# $checked_ver = "CHECKED";
+# } else {
+# $checked_any = "CHECKED";
+# }
+#
+# print "<tr><td>Show bugs applicable to</td>\n";
+# print " <td><input id=\"b_1_1\" name=vt value=none type=radio onchange=\"enable(1);\" $checked_any>anything</td></tr>\n";
+# print "<tr><td></td>";
+# print " <td><input id=\"b_1_2\" name=vt value=bysuite type=radio onchange=\"enable(1);\" $checked_sui>" . pkg_htmlselectsuite(1,2,1) . " for " . pkg_htmlselectarch(1,2,2) . "</td></tr>\n";
+#
+# if (defined $pkg) {
+# my $v = html_escape($version) || "";
+# my $pkgsane = html_escape($pkg->[0]);
+# print "<tr><td></td>";
+# print " <td><input id=\"b_1_3\" name=vt value=bypkg type=radio onchange=\"enable(1);\" $checked_ver>$pkgsane version <input id=\"b_1_3_1\" name=version value=\"$v\"></td></tr>\n";
+# } elsif (defined $src) {
+# my $v = html_escape($version) || "";
+# my $srcsane = html_escape($src->[0]);
+# print "<tr><td></td>";
+# print " <td><input name=vt value=bysrc type=radio onchange=\"enable(1);\" $checked_ver>$srcsane version <input id=\"b_1_3_1\" name=version value=\"$v\"></td></tr>\n";
+# }
+# print "<tr><td> </td></tr>\n";
+#
+# my $includetags = html_escape(join(" ", grep { !m/^subj:/i } map {split /[\s,]+/} ref($include)?@{$include}:$include));
+# my $excludetags = html_escape(join(" ", grep { !m/^subj:/i } map {split /[\s,]+/} ref($exclude)?@{$exclude}:$exclude));
+# my $includesubj = html_escape(join(" ", map { s/^subj://i; $_ } grep { m/^subj:/i } map {split /[\s,]+/} ref($include)?@{$include}:$include));
+# my $excludesubj = html_escape(join(" ", map { s/^subj://i; $_ } grep { m/^subj:/i } map {split /[\s,]+/} ref($exclude)?@{$exclude}:$exclude));
+# my $vismindays = ($mindays == 0 ? "" : $mindays);
+# my $vismaxdays = ($maxdays == -1 ? "" : $maxdays);
+#
+# my $sel_rmy = ($param{repeatmerged} ? " selected" : "");
+# my $sel_rmn = ($param{repeatmerged} ? "" : " selected");
+# my $sel_ordraw = ($ordering eq "raw" ? " selected" : "");
+# my $sel_ordold = ($ordering eq "oldview" ? " selected" : "");
+# my $sel_ordnor = ($ordering eq "normal" ? " selected" : "");
+# my $sel_ordage = ($ordering eq "age" ? " selected" : "");
+#
+# my $chk_bugrev = ($bug_rev ? " checked" : "");
+# my $chk_pendrev = ($pend_rev ? " checked" : "");
+# my $chk_sevrev = ($sev_rev ? " checked" : "");
+#
+# print <<EOF;
+# <tr><td>Only include bugs tagged with </td><td><input name=include value="$includetags"> or that have <input name=includesubj value="$includesubj"> in their subject</td></tr>
+# <tr><td>Exclude bugs tagged with </td><td><input name=exclude value="$excludetags"> or that have <input name=excludesubj value="$excludesubj"> in their subject</td></tr>
+# <tr><td>Only show bugs older than</td><td><input name=mindays value="$vismindays" size=5> days, and younger than <input name=maxdays value="$vismaxdays" size=5> days</td></tr>
+#
+# <tr><td> </td></tr>
+#
+# <tr><td>Merged bugs should be</td><td>
+# <select name=repeatmerged>
+# <option value=yes$sel_rmy>displayed separately</option>
+# <option value=no$sel_rmn>combined</option>
+# </select>
+# <tr><td>Categorise bugs by</td><td>
+# <select name=ordering>
+# <option value=raw$sel_ordraw>bug number only</option>
+# <option value=old$sel_ordold>status and severity</option>
+# <option value=normal$sel_ordnor>status, severity and classification</option>
+# <option value=age$sel_ordage>status, severity, classification, and age</option>
+# EOF
+#
+# {
+# my $any = 0;
+# my $o = $param{"ordering"} || "";
+# for my $n (keys %cats) {
+# next if ($n eq "normal" || $n eq "oldview");
+# next if defined $hidden{$n};
+# unless ($any) {
+# $any = 1;
+# print "<option disabled>------</option>\n";
+# }
+# my @names = map { ref($_) eq "HASH" ? $_->{"nam"} : $_ } @{$cats{$n}};
+# my $name;
+# if (@names == 1) { $name = $names[0]; }
+# else { $name = " and " . pop(@names); $name = join(", ", @names) . $name; }
+#
+# printf "<option value=\"%s\"%s>%s</option>\n",
+# $n, ($o eq $n ? " selected" : ""), $name;
+# }
+# }
+#
+# print "</select></td></tr>\n";
+#
+# printf "<tr><td>Order bugs by</td><td>%s</td></tr>\n",
+# pkg_htmlselectyesno("pend-rev", "outstanding bugs first", "done bugs first", $pend_rev);
+# printf "<tr><td></td><td>%s</td></tr>\n",
+# pkg_htmlselectyesno("sev-rev", "highest severity first", "lowest severity first", $sev_rev);
+# printf "<tr><td></td><td>%s</td></tr>\n",
+# pkg_htmlselectyesno("bug-rev", "oldest bugs first", "newest bugs first", $bug_rev);
+#
+# print <<EOF;
+# <tr><td> </td></tr>
+# <tr><td colspan=2><input value="Reload page" type="submit"> with new settings</td></tr>
+# EOF
+#
+# print "</table></form></div>\n";
print "<hr>\n";
print "<p>$tail_html";
print "</body></html>\n";
-sub pkg_htmlindexentrystatus {
- my $s = shift;
- my %status = %{$s};
-
- my $result = "";
-
- my $showseverity;
- if ($status{severity} eq 'normal') {
- $showseverity = '';
- } elsif (isstrongseverity($status{severity})) {
- $showseverity = "Severity: <em class=\"severity\">$status{severity}</em>;\n";
- } else {
- $showseverity = "Severity: <em>$status{severity}</em>;\n";
- }
-
- $result .= pkg_htmlpackagelinks($status{"package"}, 1);
-
- my $showversions = '';
- if (@{$status{found_versions}}) {
- my @found = @{$status{found_versions}};
- $showversions .= join ', ', map {s{/}{ }; html_escape($_)} @found;
- }
- if (@{$status{fixed_versions}}) {
- $showversions .= '; ' if length $showversions;
- $showversions .= '<strong>fixed</strong>: ';
- my @fixed = @{$status{fixed_versions}};
- $showversions .= join ', ', map {s{/}{ }; html_escape($_)} @fixed;
- }
- $result .= ' (<a href="'.
- version_url($status{package},
- $status{found_versions},
- $status{fixed_versions},
- ).qq{">$showversions</a>)} if length $showversions;
- $result .= ";\n";
-
- $result .= $showseverity;
- $result .= pkg_htmladdresslinks("Reported by: ", \&submitterurl,
- $status{originator});
- $result .= ";\nOwned by: " . html_escape($status{owner})
- if length $status{owner};
- $result .= ";\nTags: <strong>"
- . html_escape(join(", ", sort(split(/\s+/, $status{tags}))))
- . "</strong>"
- if (length($status{tags}));
-
- $result .= buglinklist(";\nMerged with ", ", ",
- split(/ /,$status{mergedwith}));
- $result .= buglinklist(";\nBlocked by ", ", ",
- split(/ /,$status{blockedby}));
- $result .= buglinklist(";\nBlocks ", ", ",
- split(/ /,$status{blocks}));
-
- if (length($status{done})) {
- $result .= "<br><strong>Done:</strong> " . html_escape($status{done});
- my $days = bug_archiveable(bug => $status{id},
- status => \%status,
- days_until => 1,
- );
- if ($days >= 0 and defined $status{location} and $status{location} ne 'archive') {
- $result .= ";\n<strong>Can be archived" . ( $days == 0 ? " today" : $days == 1 ? " in $days day" : " in $days days" ) . "</strong>";
- }
- elsif (defined $status{location} and $status{location} eq 'archived') {
- $result .= ";\n<strong>Archived.</strong>";
- }
- }
-
- unless (length($status{done})) {
- if (length($status{forwarded})) {
- $result .= ";\n<strong>Forwarded</strong> to "
- . join(', ',
- map {maybelink($_)}
- split /\,\s+/,$status{forwarded}
- );
- }
- # Check the age of the logfile
- my ($days_last,$eng_last) = secs_to_english(time - $status{log_modified});
- my ($days,$eng) = secs_to_english(time - $status{date});
-
- if ($days >= 7) {
- my $font = "";
- my $efont = "";
- $font = "em" if ($days > 30);
- $font = "strong" if ($days > 60);
- $efont = "</$font>" if ($font);
- $font = "<$font>" if ($font);
-
- $result .= ";\n ${font}$eng old$efont";
- }
- if ($days_last > 7) {
- my $font = "";
- my $efont = "";
- $font = "em" if ($days_last > 30);
- $font = "strong" if ($days_last > 60);
- $efont = "</$font>" if ($font);
- $font = "<$font>" if ($font);
-
- $result .= ";\n ${font}Modified $eng_last ago$efont";
- }
- }
-
- $result .= ".";
-
- return $result;
-}
-
-
-sub pkg_htmlizebugs {
- $b = $_[0];
- my @bugs = @$b;
-
- my @status = ();
- my %count;
- my $header = '';
- my $footer = "<h2 class=\"outstanding\">Summary</h2>\n";
-
- my @dummy = ($gRemoveAge); #, @gSeverityList, @gSeverityDisplay); #, $gHTMLExpireNote);
-
- if (@bugs == 0) {
- return "<HR><H2>No reports found!</H2></HR>\n";
- }
-
- if ( $bug_rev ) {
- @bugs = sort {$b<=>$a} @bugs;
- } else {
- @bugs = sort {$a<=>$b} @bugs;
- }
- my %seenmerged;
-
- my %common = (
- 'show_list_header' => 1,
- 'show_list_footer' => 1,
- );
-
- my %section = ();
- # Make the include/exclude map
- my %include;
- my %exclude;
- for my $include (make_list($param{include})) {
- next unless defined $include;
- my ($key,$value) = split /\s*:\s*/,$include,2;
- unless (defined $value) {
- $key = 'tags';
- $value = $include;
- }
- push @{$include{$key}}, split /\s*,\s*/, $value;
- }
- for my $exclude (make_list($param{exclude})) {
- next unless defined $exclude;
- my ($key,$value) = split /\s*:\s*/,$exclude,2;
- unless (defined $value) {
- $key = 'tags';
- $value = $exclude;
- }
- push @{$exclude{$key}}, split /\s*,\s*/, $value;
- }
-
- foreach my $bug (@bugs) {
- my %status = %{get_bug_status(bug=>$bug,
- (exists $param{dist}?(dist => $param{dist}):()),
- bugusertags => \%bugusertags,
- (exists $param{version}?(version => $param{version}):()),
- (exists $param{arch}?(arch => $param{arch}):(arch => $config{default_architectures})),
- )};
- next unless %status;
- next if bug_filter(bug => $bug,
- status => \%status,
- (exists $param{repeatmerged}?(repeat_merged => $param{repeatmerged}):()),
- seen_merged => \%seenmerged,
- (keys %include ? (include => \%include):()),
- (keys %exclude ? (exclude => \%exclude):()),
- );
-
- my $html = sprintf "<li><a href=\"%s\">#%d: %s</a>\n<br>",
- bug_url($bug), $bug, html_escape($status{subject});
- $html .= pkg_htmlindexentrystatus(\%status) . "\n";
- push @status, [ $bug, \%status, $html ];
- }
- if ($bug_order eq 'age') {
- # MWHAHAHAHA
- @status = sort {$a->[1]{log_modified} <=> $b->[1]{log_modified}} @status;
- }
- elsif ($bug_order eq 'agerev') {
- @status = sort {$b->[1]{log_modified} <=> $a->[1]{log_modified}} @status;
- }
- for my $entry (@status) {
- my $key = "";
- for my $i (0..$#prior) {
- my $v = get_bug_order_index($prior[$i], $entry->[1]);
- $count{"g_${i}_${v}"}++;
- $key .= "_$v";
- }
- $section{$key} .= $entry->[2];
- $count{"_$key"}++;
- }
-
- my $result = "";
- if ($ordering eq "raw") {
- $result .= "<UL class=\"bugs\">\n" . join("", map( { $_->[ 2 ] } @status ) ) . "</UL>\n";
- } else {
- $header .= "<div class=\"msgreceived\">\n<ul>\n";
- my @keys_in_order = ("");
- for my $o (@order) {
- push @keys_in_order, "X";
- while ((my $k = shift @keys_in_order) ne "X") {
- for my $k2 (@{$o}) {
- $k2+=0;
- push @keys_in_order, "${k}_${k2}";
- }
- }
- }
- for my $order (@keys_in_order) {
- next unless defined $section{$order};
- my @ttl = split /_/, $order; shift @ttl;
- my $title = $title[0]->[$ttl[0]] . " bugs";
- if ($#ttl > 0) {
- $title .= " -- ";
- $title .= join("; ", grep {($_ || "") ne ""}
- map { $title[$_]->[$ttl[$_]] } 1..$#ttl);
- }
- $title = html_escape($title);
-
- my $count = $count{"_$order"};
- my $bugs = $count == 1 ? "bug" : "bugs";
-
- $header .= "<li><a href=\"#$order\">$title</a> ($count $bugs)</li>\n";
- if ($common{show_list_header}) {
- my $count = $count{"_$order"};
- my $bugs = $count == 1 ? "bug" : "bugs";
- $result .= "<H2 CLASS=\"outstanding\"><a name=\"$order\"></a>$title ($count $bugs)</H2>\n";
- } else {
- $result .= "<H2 CLASS=\"outstanding\">$title</H2>\n";
- }
- $result .= "<div class=\"msgreceived\">\n<UL class=\"bugs\">\n";
- $result .= "\n\n\n\n";
- $result .= $section{$order};
- $result .= "\n\n\n\n";
- $result .= "</UL>\n</div>\n";
- }
- $header .= "</ul></div>\n";
-
- $footer .= "<div class=\"msgreceived\">\n<ul>\n";
- for my $i (0..$#prior) {
- my $local_result = '';
- foreach my $key ( @{$order[$i]} ) {
- my $count = $count{"g_${i}_$key"};
- next if !$count or !$title[$i]->[$key];
- $local_result .= "<li>$count $title[$i]->[$key]</li>\n";
- }
- if ( $local_result ) {
- $footer .= "<li>$names[$i]<ul>\n$local_result</ul></li>\n";
- }
- }
- $footer .= "</ul>\n</div>\n";
- }
-
- $result = $header . $result if ( $common{show_list_header} );
- $result .= $footer if ( $common{show_list_footer} );
- return $result;
-}
-
-sub pkg_htmlpackagelinks {
- my $pkgs = shift;
- return unless defined $pkgs and $pkgs ne '';
- my $strong = shift;
- my @pkglist = splitpackages($pkgs);
-
- $strong = 0;
- my $openstrong = $strong ? '<strong>' : '';
- my $closestrong = $strong ? '</strong>' : '';
-
- return 'Package' . (@pkglist > 1 ? 's' : '') . ': ' .
- join(', ',
- map {
- '<a class="submitter" href="' . munge_url($this,src=>[],package=>$_,newest=>[]) . '">' .
- $openstrong . html_escape($_) . $closestrong . '</a>'
- } @pkglist
- );
-}
-
-sub pkg_htmladdresslinks {
- htmlize_addresslinks(@_,'submitter');
-}
-
-sub pkg_javascript {
- return <<EOF ;
-<script type="text/javascript">
-<!--
-function pagemain() {
- toggle(1);
-// toggle(2);
- enable(1);
-}
-
-function setCookie(name, value, expires, path, domain, secure) {
- var curCookie = name + "=" + escape(value) +
- ((expires) ? "; expires=" + expires.toGMTString() : "") +
- ((path) ? "; path=" + path : "") +
- ((domain) ? "; domain=" + domain : "") +
- ((secure) ? "; secure" : "");
- document.cookie = curCookie;
-}
-
-function save_cat_cookies() {
- var cat = document.categories.categorisation.value;
- var exp = new Date();
- exp.setTime(exp.getTime() + 10 * 365 * 24 * 60 * 60 * 1000);
- var oldexp = new Date();
- oldexp.setTime(oldexp.getTime() - 1 * 365 * 24 * 60 * 60 * 1000);
- var lev;
- var done = 0;
-
- var u = document.getElementById("users");
- if (u != null) { u = u.value; }
- if (u == "") { u = null; }
- if (u != null) {
- setCookie("cat" + cat + "_users", u, exp, "/");
- } else {
- setCookie("cat" + cat + "_users", "", oldexp, "/");
- }
-
- var bits = new Array("nam", "pri", "ttl", "ord");
- for (var i = 0; i < 4; i++) {
- for (var j = 0; j < bits.length; j++) {
- var e = document.getElementById(bits[j] + i);
- if (e) e = e.value;
- if (e == null) { e = ""; }
- if (j == 0 && e == "") { done = 1; }
- if (done || e == "") {
- setCookie("cat" + cat + "_" + bits[j] + i, "", oldexp, "/");
- } else {
- setCookie("cat" + cat + "_" + bits[j] + i, e, exp, "/");
- }
- }
- }
-}
-
-function toggle(i) {
- var a = document.getElementById("a_" + i);
- if (a) {
- if (a.style.display == "none") {
- a.style.display = "";
- } else {
- a.style.display = "none";
- }
- }
-}
-
-function enable(x) {
- for (var i = 1; ; i++) {
- var a = document.getElementById("b_" + x + "_" + i);
- if (a == null) break;
- var ischecked = a.checked;
- for (var j = 1; ; j++) {
- var b = document.getElementById("b_" + x + "_"+ i + "_" + j);
- if (b == null) break;
- if (ischecked) {
- b.disabled = false;
- } else {
- b.disabled = true;
- }
- }
- }
-}
--->
-</script>
-EOF
-}
-
-sub pkg_htmlselectyesno {
- my ($name, $n, $y, $default) = @_;
- return sprintf('<select name="%s"><option value=no%s>%s</option><option value=yes%s>%s</option></select>', $name, ($default ? "" : " selected"), $n, ($default ? " selected" : ""), $y);
-}
-
-sub pkg_htmlselectsuite {
- my $id = sprintf "b_%d_%d_%d", $_[0], $_[1], $_[2];
- my @suites = ("stable", "testing", "unstable", "experimental");
- my %suiteaka = ("stable", "etch", "testing", "lenny", "unstable", "sid");
- my $defaultsuite = "unstable";
-
- my $result = sprintf '<select name=dist id="%s">', $id;
- for my $s (@suites) {
- $result .= sprintf '<option value="%s"%s>%s%s</option>',
- $s, ($defaultsuite eq $s ? " selected" : ""),
- $s, (defined $suiteaka{$s} ? " (" . $suiteaka{$s} . ")" : "");
- }
- $result .= '</select>';
- return $result;
-}
-
-sub pkg_htmlselectarch {
- my $id = sprintf "b_%d_%d_%d", $_[0], $_[1], $_[2];
- my @arches = qw(alpha amd64 arm hppa i386 ia64 m68k mips mipsel powerpc s390 sparc);
-
- my $result = sprintf '<select name=arch id="%s">', $id;
- $result .= '<option value="any">any architecture</option>';
- for my $a (@arches) {
- $result .= sprintf '<option value="%s">%s</option>', $a, $a;
- }
- $result .= '</select>';
- return $result;
-}
-
-sub myurl {
- return html_escape(pkg_url(map {exists $param{$_}?($_,$param{$_}):()}
- qw(archive repeatmerged mindays maxdays),
- qw(version dist arch pkg src tag maint submitter)
- )
- );
-}
-
-sub make_order_list {
- my $vfull = shift;
- my @x = ();
-
- if ($vfull =~ m/^([^:]+):(.*)$/) {
- my $v = $1;
- for my $vv (split /,/, $2) {
- push @x, "$v=$vv";
- }
- } else {
- for my $v (split /,/, $vfull) {
- next unless $v =~ m/.=./;
- push @x, $v;
- }
- }
- push @x, ""; # catch all
- return @x;
-}
-
-sub get_bug_order_index {
- my $order = shift;
- my $status = shift;
- my $pos = -1;
-
- my %tags = ();
- %tags = map { $_, 1 } split / /, $status->{"tags"}
- if defined $status->{"tags"};
-
- for my $el (@${order}) {
- $pos++;
- my $match = 1;
- for my $item (split /[+]/, $el) {
- my ($f, $v) = split /=/, $item, 2;
- next unless (defined $f and defined $v);
- my $isokay = 0;
- $isokay = 1 if (defined $status->{$f} and $v eq $status->{$f});
- $isokay = 1 if ($f eq "tag" && defined $tags{$v});
- unless ($isokay) {
- $match = 0;
- last;
- }
- }
- if ($match) {
- return $pos;
- last;
- }
- }
- return $pos + 1;
-}
-
-sub buglinklist {
- my ($prefix, $infix, @els) = @_;
- return '' if not @els;
- return $prefix . bug_linklist($infix,'submitter',@els);
-}
-
-
-# sets: my @names; my @prior; my @title; my @order;
-
-sub determine_ordering {
- $cats{status}[0]{ord} = [ reverse @{$cats{status}[0]{ord}} ]
- if ($pend_rev);
- $cats{severity}[0]{ord} = [ reverse @{$cats{severity}[0]{ord}} ]
- if ($sev_rev);
-
- my $i;
- if (defined $param{"pri0"}) {
- my @c = ();
- $i = 0;
- while (defined $param{"pri$i"}) {
- my $h = {};
-
- my ($pri) = make_list($param{"pri$i"});
- if ($pri =~ m/^([^:]*):(.*)$/) {
- $h->{"nam"} = $1; # overridden later if necesary
- $h->{"pri"} = [ map { "$1=$_" } (split /,/, $2) ];
- } else {
- $h->{"pri"} = [ split /,/, $pri ];
- }
-
- ($h->{"nam"}) = make_list($param{"nam$i"})
- if (defined $param{"nam$i"});
- $h->{"ord"} = [ map {split /\s*,\s*/} make_list($param{"ord$i"}) ]
- if (defined $param{"ord$i"});
- $h->{"ttl"} = [ map {split /\s*,\s*/} make_list($param{"ttl$i"}) ]
- if (defined $param{"ttl$i"});
-
- push @c, $h;
- $i++;
- }
- $cats{"_"} = [@c];
- $ordering = "_";
- }
-
- $ordering = "normal" unless defined $cats{$ordering};
-
- sub get_ordering {
- my @res;
- my $cats = shift;
- my $o = shift;
- for my $c (@{$cats->{$o}}) {
- if (ref($c) eq "HASH") {
- push @res, $c;
- } else {
- push @res, get_ordering($cats, $c);
- }
- }
- return @res;
- }
- my @cats = get_ordering(\%cats, $ordering);
-
- sub toenglish {
- my $expr = shift;
- $expr =~ s/[+]/ and /g;
- $expr =~ s/[a-z]+=//g;
- return $expr;
- }
-
- $i = 0;
- for my $c (@cats) {
- $i++;
- push @prior, $c->{"pri"};
- push @names, ($c->{"nam"} || "Bug attribute #" . $i);
- if (defined $c->{"ord"}) {
- push @order, $c->{"ord"};
- } else {
- push @order, [ 0..$#{$prior[-1]} ];
- }
- my @t = @{ $c->{"ttl"} } if defined $c->{ttl};
- if (@t < $#{$prior[-1]}) {
- push @t, map { toenglish($prior[-1][$_]) } @t..($#{$prior[-1]});
- }
- push @t, $c->{"def"} || "";
- push @title, [@t];
- }
-}
# soapy is stupid, and is using the 1999 schema; override it.
*SOAP::XMLSchema1999::Serializer::as_base64Binary = \&SOAP::XMLSchema2001::Serializer::as_base64Binary;
*SOAP::Serializer::as_anyURI = \&SOAP::XMLSchema2001::Serializer::as_string;
-$soap-> handle;
+# to work around the serializer improperly using date/time stuff
+# (Nothing in Debbugs should be looked at as if it were date/time) we
+# kill off all of the date/time related bits in the serializer.
+my $typelookup = $soap->serializer()->{_typelookup};
+for my $key (keys %{$typelookup}) {
+ next unless /Month|Day|Year|date|time|duration/i;
+ delete $typelookup->{$key};
+}
+$soap->handle;
use CGI::Simple;
-use CGI::Alert 'don@donarmstrong.com';
+# by default send this message nowhere
+use CGI::Alert q(nobody@example.com);
use Debbugs::Config qw(:config);
+
+BEGIN{
+ $CGI::Alert::Maintainer = $config{maintainer};
+}
+
use Debbugs::CGI qw(htmlize_packagelinks html_escape cgi_parameters munge_url);
use Debbugs::Versions;
use Debbugs::Versions::Dpkg;
png => 'image/png',
);
-my $q = new CGI::Simple;
+my $q = CGI::Simple->new();
my %cgi_var = cgi_parameters(query => $q,
single => [qw(package format ignore_boring width height collapse info)],
my $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp);
foreach my $source (keys %sources) {
my $srchash = substr $source, 0, 1;
- my $version_fh = new IO::File "$config{version_packages_dir}/$srchash/$source", 'r';
+ next unless -e "$config{version_packages_dir}/$srchash/$source";
+ my $version_fh = IO::File->new("$config{version_packages_dir}/$srchash/$source", 'r') or
+ warn "Unable to open $config{version_packages_dir}/$srchash/$source for reading: $!";
$version->load($version_fh);
}
# Here, we need to generate a short version to full version map
# are in the same state as their parent, and are not in a suite
foreach my $key (keys %reversed_nodes) {
my ($short_version) = $key =~ m{/(.+)$};
- if (not exists $version_to_dist{$short_version}
+ if (not exists $version_to_dist{$key}
and @{$reversed_nodes{$key}} <= 1
and defined $version->{parent}{$key}
and $all_states{$key} eq $all_states{$version->{parent}{$key}}
or $all_states{$key} eq 'absent');
next if $cgi_var{ignore_boring} and not version_relevant($version,$key,\@interesting_versions);
my @attributes = @{$state{$all_states{$key}}};
- if (length $short_version and exists $version_to_dist{$short_version}) {
- push @attributes, 'label="'.$key.'\n'."(".join(', ',@{$version_to_dist{$short_version}}).")\"";
+ if (exists $version_to_dist{$key}) {
+ push @attributes, 'label="'.$key.'\n'."(".join(', ',@{$version_to_dist{$key}}).")\"";
}
my $node_attributes = qq("$key" [).join(',',@attributes).qq(]\n);
$dot .= $node_attributes;
my $temp_dir = tempdir(CLEANUP => 1);
if (not defined $cgi_var{dot}) {
- my $dot_fh = new IO::File "$temp_dir/temp.dot",'w' or
+ my $dot_fh = IO::File->new("$temp_dir/temp.dot",'w') or
die "Unable to open $temp_dir/temp.dot for writing: $!";
print {$dot_fh} $dot or die "Unable to print output to the dot file: $!";
close $dot_fh or die "Unable to close the dot file: $!";
system('dot','-T'.$cgi_var{format},"$temp_dir/temp.dot",'-o',"$temp_dir/temp.$cgi_var{format}") == 0
or print "Content-Type: text\n\nDot failed." and die "Dot failed: $?";
- my $img_fh = new IO::File "$temp_dir/temp.$cgi_var{format}", 'r' or
+ my $img_fh = IO::File->new("$temp_dir/temp.$cgi_var{format}", 'r') or
die "Unable to open $temp_dir/temp.$cgi_var{format} for reading: $!";
print "Content-Type: $img_types{$cgi_var{format}}\n\n";
print <$img_fh>;
debbugs (2.4.2) UNRELEASED; urgency=low
- * Anthony Towns:
- - Add "package" command to service (control@) to limit the bugs that
- the following commands apply to.
-
- * Colin Watson:
- - Add (slightly) fancy CGI decoding of message/* MIME types.
- - CGI scripts now support multiple maintainers for a single package.
- - Add support for an X-Debbugs-No-Ack: mail header to suppress
- acknowledgements.
- - Document how to deliver mail to debbugs via procmail and SpamAssassin.
- - Implement new .status format that's extensible and easier to read; it
- now lives in .summary rather than .status. Use debbugs-upgradestatus
- to convert existing bug databases.
- - Implement bug ownership, with new 'owner' and 'noowner' commands and
- Owner: pseudo-header (closes: #133453).
- - Install Debian configuration in the binary package's examples
- directory (closes: #222118).
- - New standalone SpamAssassin queue runner, spamscan.
- - Allow # prefix on bug numbers in 'merge' command.
- - Fix some ordering issues in old-style package pages and summaries.
- - Add X-$gProject-PR-Message: headers to all mails sent by service.
- - debbugsconfig creates required directories in $gSpoolDir
- (closes: #222077).
- - Decode RFC1522 mail headers for display in the web interface.
- bugreport.cgi and pkgreport.cgi now output UTF-8.
- - Properly support multiple submitter addresses on a single bug.
- - Add a number of extra htmlsanit() calls to prevent cross-site
- scripting attacks.
-
- * Adam Heath:
- - Rewrite filtering in cgi's common.pl, to make it completely generic.
- Filtering can now work against any field.
- - Rewrite grouping logic in cgi's common.pl, to make it completely
- generic. There is now no longer 2 nested loops, to do the grouping.
- This makes adding new grouping levels simpler for the future.
- - Add in a Table of Contents to pkgreport.cgi.
- - Display how long until a resolved bug will be archived in
- pkgreport.cgi.
- - Add user-agent detection. This currently doesn't change anything,
- however.
- - Add options show_list_(head|foot)er.
-
- * Don Armstrong:
-
- - Don't remove the maintainer address if the message was sent by the
- maintainer and we're submitting to maintonly (closes: #140061)
- - Use uri_escape to escape URI's before sending them back out so the
- name of the file doesn't munge the query string. [#301606 pt. 1]
- - call decode_rfc1522 on the filename returned so that encoded
- filenames get decoded to something "reasonable." (closes: #301606)
- - We now require URI::Escape
- - Added apache.conf to examples, which is a sample apache
- configuration file which implements the rewrite rules that are
- currently used on bugs.debian.org. (closes: #222264)
- - Change spamscan.in to work with SA 3.0; This is an incompatible
- change with SA 2.6, and as such, we now Suggests: spamassassin
- (>=3.0) (closes: #290501)
- - Update MTA to exim4 (closes: #228597) and add instructions on using
- exim 4 (thanks to Marc Haber) (closes: #248335)
- - Added per bug subscription support to debbugs, which relies on an
- external MLM to actually deal with the requests; currently works with
- eoc and sends messages to bugnum\@$gListDomain. (closes: #34071)
- - Change bugreport.cgi to use Debbugs::Log and greately simplify the
- process of outputing the bug log.
- - All RFC1522 subject lines are decoded, both in the html information
- and the message headers. All messages are converted to UTF-8 whereever
- possible; all bugreport.cgi pages are now completely in UTF-8 to the
- degree possible using Encode.pm (closes: #46848,#238984)
- - Add a convert_to_utf8 function to Debbugs::Mime to make the above
- possible; abstracts functionality that was already present in the
- decode_rfc1522 fucntionality.
- - Individual messages can now be downloaded from each bug report
- (closes: #95373)
- - Uninteresting headers are now hidden by default, can be renabled
- with &trim=no (closes: #188561)
- - Fix postfix instructions in README.mail (thanks to Jeff Teunissen)
- (closes: #134166)
- - Display old severity when changing severity (closes: #196947)
- - All messages that originate from the BTS and either go to .log files
- or out to users are now properly RFC1522 encoded. (closes: #306068)
- - Add links to cloned bugs (closes: #217960) and forwarded records
- that look like urls in the html records output by bugreport.cgi.
- - Things that look like urls in message bodies are now linked
- (closes: #168962)
- - Add Debbugs::Mail module that has two important functions:
- send_mail_message and encode_headers. All mail handling in service.in
- and process.in now uses send_mail_message to send mail messages which
- tries as hard as possible to send a message; if it fails, only
- warnings are returned. This fixes bad addresses causing sendmail to
- exit and destroying the bug log. (closes: #191306)
- - Add rudimentary Test::More modules for testing Debbugs::Mime and
- Debbugs::Mail.
- - Allow X-debbugs-* to be set in pseudo headers. (closes: #179340)
- - Obey X-Debbugs-No-Ack in control@ messages. (closes: #201825)
- - Allow forwarded: and owner to be set at submit@ time.
- (closes:#128320)
- - Fix example rewrite rules to allow for #1234 and foo+bar@baz.com
- (closes: #321925)
- - Output proper charset for attachments (closes: #335813)
- - Use MIME encodings to attach messages in close and done.
- (closes: #136654)
- - Add a forcemerge command to service.in to allow forcibly merging
- bugs which are in the same package. (closes: #286792)
- - Make all packages lowercase to support packages with uppercase
- names, even though that's insane. (closes: #67067)
- - Change acknowledged to close (closes: #61341) and indicate who
- actually closed the bug (closes: #355968, #132274)
- - Fix the documentation of clone to indicate that you need at least
- one newID (closes: #276747)
- - Use create_mime_message to send all of the mails which may contain
- UTF8 material. (closes: #364026)
- - Add links to Closes: text for closed bugs. (closes: #320986)
- - Add X-$gProject-PR-Source: line (closes: #219230)
- - Use the %cats data structure properly in pkgreport.cgi
- (closes: #367514)
- - Document nnn.*@foobar addresses (closes: #188670)
- - Support cloned bugs in control blocking (closes: #337329)
- - Indicate which bugs are blocked after blocking (closes: #367496)
- - Obey package for usertags (closes: #376528)
- - Add link to subscribe to a bug (closes: #353260)
- - Don't lc owner or forwarded at submit time (closes: #288384)
- - Explain how to close bugs in the ack message (closes: #37605)
- - Make the moreinfo ack more general (closes: #70810)
- - Use RFC compliant dates in headers (closes: #362935)
- - Add SOAP support (closes: #377520) Thanks to Raphael Hertzog.
- - Split forwarded on commas for linking (closes: #367813,#473272)
- - Don't display duplicate bugs (closes: #348116)
- - Display links to archived bugs for all searches (closes: #53710)
- - Link to blocked bugs in the bugreport.cgi output (closes: #326077)
- - Don't ask for more bugs if there is no maintainer (closes: #355190)
- - Stop refering to developers on the index page (closes: #355786)
- - Change control@ stop regex and documentation to match eachother
- (closes: #366093)
- - Make it obvious when commands to control have failed
- (closes: #344184)
- - Fix javascript error in pkgreport.cgi (closes: #346043)
- - When a bug can't be found in control@; indicate to user that it may
- be archived. (closes: #153536)
- - my_url in pkgreport.cgi now returns the complete url (closes: #378566)
- - Document precisely how forwarded works (closes: #228049)
- - Dissallow forwarded being set to a $gEmailDomain address
- (closes: #397486)
- - Fix broken sorting by usertags by forcing numeric (closes: #395027)
- - Add support for hiding useless messages; thanks to Sune Vuorela.
- (closes: #406020)
- - Fix arrayrefs leaking into the myurl function (closes: #397344)
- - List bugs being blocked (closes: #356680)
- - Fix multiple submitters for a single bug in the index
- (closes: #402362)
- - Marking a bug as fixed now overrides a found at that exact version
- (closes: #395865)
- - When searching by source package, include the source package itself
- in the list of packages to search for, even if there is no binary
- package called that. (closes: #414825)
- - Add link from singlemsg page to main page; remove useless links
- (closes: #404806)
- - Support usertagging cloned bugs (closes: #375697)
- - List previous/new title when retitling, and show date of control
- actions (closes: #127354)
- - Add searching by owner (closes: #345407)
- - Accept colon after package in control mails (closes: #319720)
- - Make e-mail addresses case insensitive for searching
- (closes: #89569)
- - pkgindex.cgi limits its output with pagination (closes: #23018)
- - lc submitter address for comparsion in pkgreport.cgi
- (closes: #415628)
- - Add quotes around retitle'd titles (closes: #419202)
- - Don't automatically make categories hidden (closes: #415932)
- - Don't duplicate ordering (closes: #415931)
- - Make file locking portable (closes: #293277)
- - Allow the package pages to be optional (closes: #234362)
- - Fix package link code and link both packages (closes: #419553)
- - Save leading space when we unmime (closes: #416321)
- - Make the version regex correct (closes: #425614)
- - Indicate the selected user (closes: #422934)
- - Use source package for usertags where possible (closes: #415933)
- - Add PR-Package header for control messages (closes: #414023)
- - Fix double leading spaces of format=flowed messages
- (closes: #428056)
- - Don't doubly select users
- - Implement versioning aware archiving support (closes: #339141)
- - Split out packages so that you don't have to install the mail stuff
- unless you want it.
- - Only mail duplicated recipients once (closes: #172635)
- - Indicate date of last activity (closes: #207065)
- - Reorder title (closes: #265267)
- - Reopen bugs when a bug is found with a version greater than any
- fixed version (closes: #365352)
- - Allow ordering bugs by last action (closes: #318898)
- - Add notfixed/notfound commands (closes: #389634)
- - Fix soapy insanity (closes: #422062)
- - Add script to split index.db by severities (closes: #422062)
- - Add bugspam.cgi with confirm string (closes: #348225)
- - Allow selecting both archived and unarchived bugs (closes: #320175)
- - Support intersecting sets of bugs (closes: #164421)
- - Allow selecting the newest N bugs (closes: #84681)
- - Add anchor links to specific messages (closes: #431450)
- - Add missing newline after indicating what the user is (closes: #432466)
- - Handle src/binary packages with the same name (but different src
- packages) correctly. (closes: #435926)
- - Make sendmail binary location configurable, and use flock instead of
- fcntl. (closes: #260791)
- - Make notfound/notfixed log verbiage more clear (closes: #434953)
- - Verify submitter is a valid email according to RFC822
- (closes: #182419)
- - Indicate what message number a message is (closes: #462653,#454248)
- - Fix casing of versions (closes: #441022)
- - Output last-modified in bugreport.cgi (closes: #459709)
- - Fix various html syntax errors in pkgreport.cgi (closes: #462322)
- - Make search case insensitive (closes: #448861)
- - Add the ability to return source/package mapping
- (closes: #465332,#458822)
- - Deal properly with \r line endings (closes: #467190)
- - Distinguish between reports and followups (closes: #459866)
+ [ Anthony Towns ]
+ * Add "package" command to service (control@) to limit the bugs that
+ the following commands apply to.
+
+ [ Colin Watson ]
+ * Add (slightly) fancy CGI decoding of message/* MIME types.
+ * CGI scripts now support multiple maintainers for a single package.
+ * Add support for an X-Debbugs-No-Ack: mail header to suppress
+ acknowledgements.
+ * Document how to deliver mail to debbugs via procmail and SpamAssassin.
+ * Implement new .status format that's extensible and easier to read; it
+ now lives in .summary rather than .status. Use debbugs-upgradestatus
+ to convert existing bug databases.
+ * Implement bug ownership, with new 'owner' and 'noowner' commands and
+ Owner: pseudo-header (closes: #133453).
+ * Install Debian configuration in the binary package's examples
+ directory (closes: #222118).
+ * New standalone SpamAssassin queue runner, spamscan.
+ * Allow # prefix on bug numbers in 'merge' command.
+ * Fix some ordering issues in old-style package pages and summaries.
+ * Add X-$gProject-PR-Message: headers to all mails sent by service.
+ * debbugsconfig creates required directories in $gSpoolDir
+ (closes: #222077).
+ * Decode RFC1522 mail headers for display in the web interface.
+ bugreport.cgi and pkgreport.cgi now output UTF-8.
+ * Properly support multiple submitter addresses on a single bug.
+ * Add a number of extra htmlsanit() calls to prevent cross-site
+ scripting attacks.
+
+ [ Adam Heath ]
+ * Rewrite filtering in cgi's common.pl, to make it completely generic.
+ Filtering can now work against any field.
+ * Rewrite grouping logic in cgi's common.pl, to make it completely
+ generic. There is now no longer 2 nested loops, to do the grouping.
+ This makes adding new grouping levels simpler for the future.
+ * Add in a Table of Contents to pkgreport.cgi.
+ * Display how long until a resolved bug will be archived in
+ pkgreport.cgi.
+ * Add user-agent detection. This currently doesn't change anything,
+ however.
+ * Add options show_list_(head|foot)er.
+
+ [ Don Armstrong ]
+ * Don't remove the maintainer address if the message was sent by the
+ maintainer and we're submitting to maintonly (closes: #140061)
+ * Use uri_escape to escape URI's before sending them back out so the
+ name of the file doesn't munge the query string. [#301606 pt. 1]
+ * call decode_rfc1522 on the filename returned so that encoded
+ filenames get decoded to something "reasonable." (closes: #301606)
+ * We now require URI::Escape
+ * Added apache.conf to examples, which is a sample apache
+ configuration file which implements the rewrite rules that are
+ currently used on bugs.debian.org. (closes: #222264)
+ * Change spamscan.in to work with SA 3.0; This is an incompatible
+ change with SA 2.6, and as such, we now Suggests: spamassassin
+ (>=3.0) (closes: #290501)
+ * Update MTA to exim4 (closes: #228597) and add instructions on using
+ exim 4 (thanks to Marc Haber) (closes: #248335)
+ * Added per bug subscription support to debbugs, which relies on an
+ external MLM to actually deal with the requests; currently works with
+ eoc and sends messages to bugnum\@$gListDomain. (closes: #34071)
+ * Change bugreport.cgi to use Debbugs::Log and greately simplify the
+ process of outputing the bug log.
+ * All RFC1522 subject lines are decoded, both in the html information
+ and the message headers. All messages are converted to UTF-8 whereever
+ possible; all bugreport.cgi pages are now completely in UTF-8 to the
+ degree possible using Encode.pm (closes: #46848,#238984)
+ * Add a convert_to_utf8 function to Debbugs::Mime to make the above
+ possible; abstracts functionality that was already present in the
+ decode_rfc1522 fucntionality.
+ * Individual messages can now be downloaded from each bug report
+ (closes: #95373)
+ * Uninteresting headers are now hidden by default, can be renabled
+ with &trim=no (closes: #188561)
+ * Fix postfix instructions in README.mail (thanks to Jeff Teunissen)
+ (closes: #134166)
+ * Display old severity when changing severity (closes: #196947)
+ * All messages that originate from the BTS and either go to .log files
+ or out to users are now properly RFC1522 encoded. (closes: #306068)
+ * Add links to cloned bugs (closes: #217960) and forwarded records
+ that look like urls in the html records output by bugreport.cgi.
+ * Things that look like urls in message bodies are now linked
+ (closes: #168962)
+ * Add Debbugs::Mail module that has two important functions:
+ send_mail_message and encode_headers. All mail handling in service.in
+ and process.in now uses send_mail_message to send mail messages which
+ tries as hard as possible to send a message; if it fails, only
+ warnings are returned. This fixes bad addresses causing sendmail to
+ exit and destroying the bug log. (closes: #191306)
+ * Add rudimentary Test::More modules for testing Debbugs::Mime and
+ Debbugs::Mail.
+ * Allow X-debbugs-* to be set in pseudo headers. (closes: #179340)
+ * Obey X-Debbugs-No-Ack in control@ messages. (closes: #201825)
+ * Allow forwarded: and owner to be set at submit@ time.
+ (closes:#128320)
+ * Fix example rewrite rules to allow for #1234 and foo+bar@baz.com
+ (closes: #321925)
+ * Output proper charset for attachments (closes: #335813)
+ * Use MIME encodings to attach messages in close and done.
+ (closes: #136654)
+ * Add a forcemerge command to service.in to allow forcibly merging
+ bugs which are in the same package. (closes: #286792)
+ * Make all packages lowercase to support packages with uppercase
+ names, even though that's insane. (closes: #67067)
+ * Change acknowledged to close (closes: #61341) and indicate who
+ actually closed the bug (closes: #355968, #132274)
+ * Fix the documentation of clone to indicate that you need at least
+ one newID (closes: #276747)
+ * Use create_mime_message to send all of the mails which may contain
+ UTF8 material. (closes: #364026)
+ * Add links to Closes: text for closed bugs. (closes: #320986)
+ * Add X-$gProject-PR-Source: line (closes: #219230)
+ * Use the %cats data structure properly in pkgreport.cgi
+ (closes: #367514)
+ * Document nnn.*@foobar addresses (closes: #188670)
+ * Support cloned bugs in control blocking (closes: #337329)
+ * Indicate which bugs are blocked after blocking (closes: #367496)
+ * Obey package for usertags (closes: #376528)
+ * Add link to subscribe to a bug (closes: #353260)
+ * Don't lc owner or forwarded at submit time (closes: #288384)
+ * Explain how to close bugs in the ack message (closes: #37605)
+ * Make the moreinfo ack more general (closes: #70810)
+ * Use RFC compliant dates in headers (closes: #362935)
+ * Add SOAP support (closes: #377520) Thanks to Raphael Hertzog.
+ * Split forwarded on commas for linking (closes: #367813,#473272)
+ * Don't display duplicate bugs (closes: #348116)
+ * Display links to archived bugs for all searches (closes: #53710)
+ * Link to blocked bugs in the bugreport.cgi output (closes: #326077)
+ * Don't ask for more bugs if there is no maintainer (closes: #355190)
+ * Stop refering to developers on the index page (closes: #355786)
+ * Change control@ stop regex and documentation to match eachother
+ (closes: #366093)
+ * Make it obvious when commands to control have failed
+ (closes: #344184)
+ * Fix javascript error in pkgreport.cgi (closes: #346043)
+ * When a bug can't be found in control@; indicate to user that it may
+ be archived. (closes: #153536)
+ * my_url in pkgreport.cgi now returns the complete url (closes: #378566)
+ * Document precisely how forwarded works (closes: #228049)
+ * Dissallow forwarded being set to a $gEmailDomain address
+ (closes: #397486)
+ * Fix broken sorting by usertags by forcing numeric (closes: #395027)
+ * Add support for hiding useless messages; thanks to Sune Vuorela.
+ (closes: #406020)
+ * Fix arrayrefs leaking into the myurl function (closes: #397344)
+ * List bugs being blocked (closes: #356680)
+ * Fix multiple submitters for a single bug in the index
+ (closes: #402362)
+ * Marking a bug as fixed now overrides a found at that exact version
+ (closes: #395865)
+ * When searching by source package, include the source package itself
+ in the list of packages to search for, even if there is no binary
+ package called that. (closes: #414825)
+ * Add link from singlemsg page to main page; remove useless links
+ (closes: #404806)
+ * Support usertagging cloned bugs (closes: #375697)
+ * List previous/new title when retitling, and show date of control
+ actions (closes: #127354)
+ * Add searching by owner (closes: #345407)
+ * Accept colon after package in control mails (closes: #319720)
+ * Make e-mail addresses case insensitive for searching
+ (closes: #89569)
+ * pkgindex.cgi limits its output with pagination (closes: #23018)
+ * lc submitter address for comparsion in pkgreport.cgi
+ (closes: #415628)
+ * Add quotes around retitle'd titles (closes: #419202)
+ * Don't automatically make categories hidden (closes: #415932)
+ * Don't duplicate ordering (closes: #415931)
+ * Make file locking portable (closes: #293277)
+ * Allow the package pages to be optional (closes: #234362)
+ * Fix package link code and link both packages (closes: #419553)
+ * Save leading space when we unmime (closes: #416321)
+ * Make the version regex correct (closes: #425614)
+ * Indicate the selected user (closes: #422934)
+ * Use source package for usertags where possible (closes: #415933)
+ * Add PR-Package header for control messages (closes: #414023)
+ * Fix double leading spaces of format=flowed messages
+ (closes: #428056)
+ * Don't doubly select users
+ * Implement versioning aware archiving support (closes: #339141)
+ * Split out packages so that you don't have to install the mail stuff
+ unless you want it.
+ * Only mail duplicated recipients once (closes: #172635)
+ * Indicate date of last activity (closes: #207065)
+ * Reorder title (closes: #265267)
+ * Reopen bugs when a bug is found with a version greater than any
+ fixed version (closes: #365352)
+ * Allow ordering bugs by last action (closes: #318898)
+ * Add notfixed/notfound commands (closes: #389634)
+ * Fix soapy insanity (closes: #422062)
+ * Add script to split index.db by severities (closes: #422062)
+ * Add bugspam.cgi with confirm string (closes: #348225)
+ * Allow selecting both archived and unarchived bugs (closes: #320175)
+ * Support intersecting sets of bugs (closes: #164421)
+ * Allow selecting the newest N bugs (closes: #84681)
+ * Add anchor links to specific messages (closes: #431450)
+ * Add missing newline after indicating what the user is (closes: #432466)
+ * Handle src/binary packages with the same name (but different src
+ packages) correctly. (closes: #435926)
+ * Make sendmail binary location configurable, and use flock instead of
+ fcntl. (closes: #260791)
+ * Make notfound/notfixed log verbiage more clear (closes: #434953)
+ * Verify submitter is a valid email according to RFC822
+ (closes: #182419)
+ * Indicate what message number a message is (closes: #462653,#454248)
+ * Fix casing of versions (closes: #441022)
+ * Output last-modified in bugreport.cgi (closes: #459709)
+ * Fix various html syntax errors in pkgreport.cgi (closes: #462322)
+ * Make search case insensitive (closes: #448861)
+ * Add the ability to return source/package mapping
+ (closes: #465332,#458822)
+ * Deal properly with \r line endings (closes: #467190)
+ * Distinguish between reports and followups (closes: #459866)
+ * Allow for the archiving of bugs in removed packages (closes: #475622)
+ * Add Text::Template based templating system (closes: #36814)
+ * Add new uservalue feature to Debbugs::User
+ * Don't serialize things as date/time in soap (closes: #484789)
-- Colin Watson <cjwatson@debian.org> Fri, 20 Jun 2003 18:57:25 +0100
color: #000;
background: #fefefe;
font-family: serif;
- margin: 1em;
+ margin: 0;
border: 0;
padding: 0;
line-height: 120%;
}
body {
- margin: 0;
+ margin: 10px;
border: 0;
padding: 0;
}
color: #686868;
}
+.buginfo p
+{
+ font-family: sans-serif;
+ font-size: 110%;
+ margin-bottom: 0px
+}
+
+.buginfo p + p
+{
+ margin: 0;
+ margin-top: 0px;
+ border: 0;
+}
+
+
+.pkginfo p
+{ font-family: sans-serif;
+ font-size: 110%;
+ margin-bottom: 0px
+}
+
+.pkginfo p + p
+{
+ margin: 0;
+ margin-top: 0px;
+ padding: 0;
+ border: 0;
+}
+
+
+.versiongraph
+{
+ float: right
+
+}
+
pre.tags {
color: #a3a3a3;
font-size: 90%;
list-style-type: square;
}
+.shortbugstatus
+{
+ font-family: sans-serif;
+
+ }
+
+.shortbugstatusextra
+{ font-family: sans-serif;
+ margin: 5px;
+ margin-top: 2px;
+ padding: 5px;
+ /* display: none; */
+ /* z-index: 1; */
+ /* position: absolute; */
+ left: 120px;
+ background-color: #ffffff;
+/* border: #000 1px solid; */
+ position: static;
+ display: block;
+ border: 0;
+ }
+
+.shortbugstatusextra span
+{ margin: 0;
+ margin-top: 0px;
+ padding: 0;
+ border: 0;
+ display: block;
+ }
+
.bugs li {
margin-top: 5px;
}
--- /dev/null
+#!/bin/sh
+# $Id: age-1.in,v 1.3 2002/01/06 10:46:24 ajt Exp $
+set -e
+cd /var/lib/debbugs/spool/db-h
+test -f ./-3.log && rm ./-3.log
+test -f ./-2.log && mv ./-2.log ./-3.log
+test -f ./-1.log && mv ./-1.log ./-2.log
+#rm -f ../stamp.html
+++ /dev/null
-#!/bin/sh
-# $Id: age-1.in,v 1.3 2002/01/06 10:46:24 ajt Exp $
-set -e
-cd /var/lib/debbugs/spool/db-h
-test -f ./-3.log && rm ./-3.log
-test -f ./-2.log && mv ./-2.log ./-3.log
-test -f ./-1.log && mv ./-1.log ./-2.log
-#rm -f ../stamp.html
--- /dev/null
+# -*- mode: cperl -*-
+# This is the template debbugs configuration file.
+# You *must* edit it in order for debbugs to work.
+# $Id: config.in,v 1.23 2005/07/17 19:07:01 cjwatson Exp $
+
+# Domains
+$gEmailDomain = "bugs.something"; # e.g. bugs.debian.org
+$gListDomain = "lists.something"; # e.g. lists.debian.org
+$gWebHost = "localhost"; # e.g. www.debian.org
+$gWebHostBugDir = "Bugs"; # e.g. Bugs
+# For now, don't change this one manually!
+$gWebDomain = "$gWebHost/$gWebHostBugDir";
+$gHTMLSuffix = ".html";
+$gCGIDomain = "$gWebDomain/cgi"; # e.g. cgi.debian.org
+$gMirrors = ""; # comma separated list
+$gPackagePages = "packages.debian.org"; # e.g. packages.debian.org
+$gSubscriptionDomain = "packages.something"; # e.g. packages.qa.debian.org
+
+# Project identification
+$gProject = "Something"; # e.g. Debian
+$gProjectTitle = "Something DebBugs Test"; # e.g. Debian GNU/Linux
+# Person(s) responsible for this installation
+$gMaintainer = "Local DebBugs Owner"; # e.g. Ian Jackson
+$gMaintainerWebpage = "http://localhost/~owner"; # e.g. http://www.debian.org/~iwj
+$gMaintainerEmail = "root\@something"; # e.g. owner@bugs.debian.org
+$gUnknownMaintainerEmail = "$gMaintainerEmail"; # e.g. unknown-package@qa.debian.org
+
+# BTS mailing lists, at $gListDomain
+# if you don't want lists, set them all to $gMaintainerEmail
+# if you don't want that mail at all, filter it out somehow :)
+$gSubmitList = "bug-submit-list"; # e.g. debian-bugs-dist
+$gMaintList = "bug-maint-list"; # e.g. debian-bugs-dist
+$gQuietList = "bug-quiet-list"; # e.g. debian-bugs-dist
+$gForwardList = "bug-forward-list"; # e.g. debian-bugs-forwarded
+$gDoneList = "bug-done-list"; # e.g. debian-bugs-closed
+$gRequestList = "bug-request-list"; # e.g. debian-bugs-dist
+$gSubmitterList = "bug-submitter-list"; # e.g. debian-bugs-dist
+$gControlList = "bug-control-list"; # e.g. debian-bugs-dist
+$gSummaryList = "bug-summary-list"; # e.g. debian-bugs-reports
+$gMirrorList = "bug-mirrors-list"; # sends to all mirrors
+
+# Various configurable options
+$gMailer = "exim"; # valid: exim, qmail and sendmail
+$gBug = "bug"; # how to spell `bug'
+$gBugs = "bugs"; # how to spell `bugs'
+$gRemoveAge = 28; # days after closed bugs are cleaned out,
+ # 0 disables
+$gSaveOldBugs = 1; # whether to archive such bugs
+$gDefaultSeverity = "normal";
+$gShowSeverities = "critical, grave, normal, minor, wishlist";
+@gStrongSeverities = ( 'critical', 'grave' );
+@gSeverityList = ( 'critical', 'grave', 'normal', 'wishlist' );
+%gSeverityDisplay = ( 'critical', "Critical $gBugs",
+ 'grave', "Grave $gBugs",
+ 'normal', "Normal $gBugs",
+ 'wishlist', "Wishlist items" );
+@gTags = ( 'patch', 'wontfix', 'moreinfo', 'unreproducible', 'fixed', 'stable' );
+
+# better don't change this
+$gBounceFroms = "^mailer|^da?emon|^post.*mast|^root|^wpuser|^mmdf|^smt.*|^mrgate|^vmmail|^mail.*system|^uucp|-maiser-|^mal\@|^mail.*agent|^tcpmail|^bitmail|^mailman";
+
+# Directories -- do _not_ change their locations.
+# They are currently hardcoded, variables are here for future expansion.
+$gConfigDir = "/etc/debbugs"; # directory where this file is
+$gSpoolDir = "/var/lib/debbugs/spool"; # working directory
+$gIncomingDir = "incoming"; # unprocessed e-mails
+$gWebDir = "/var/lib/debbugs/www"; # base location of web pages
+$gDocDir = "/var/lib/debbugs/www/txt"; # location of text doc files
+
+# Required data files
+$gMaintainerFile = "$gConfigDir/Maintainers";
+$gMaintainerFileOverride = "$gConfigDir/Maintainers.override";
+$gPseudoDescFile = "$gConfigDir/pseudo-packages.description";
+$gPackageSource = "$gConfigDir/indices/sources";
+
+
+# Estraier Configuration
+%gSearchEstraier = (url => 'http://localhost:1978/node/bts1',
+ user => 'user',
+ pass => 'pass',
+ );
+
+1;
+++ /dev/null
-# -*- mode: cperl -*-
-# This is the template debbugs configuration file.
-# You *must* edit it in order for debbugs to work.
-# $Id: config.in,v 1.23 2005/07/17 19:07:01 cjwatson Exp $
-
-# Domains
-$gEmailDomain = "bugs.something"; # e.g. bugs.debian.org
-$gListDomain = "lists.something"; # e.g. lists.debian.org
-$gWebHost = "localhost"; # e.g. www.debian.org
-$gWebHostBugDir = "Bugs"; # e.g. Bugs
-# For now, don't change this one manually!
-$gWebDomain = "$gWebHost/$gWebHostBugDir";
-$gHTMLSuffix = ".html";
-$gCGIDomain = "$gWebDomain/cgi"; # e.g. cgi.debian.org
-$gMirrors = ""; # comma separated list
-$gPackagePages = "packages.debian.org"; # e.g. packages.debian.org
-$gSubscriptionDomain = "packages.something"; # e.g. packages.qa.debian.org
-
-# Project identification
-$gProject = "Something"; # e.g. Debian
-$gProjectTitle = "Something DebBugs Test"; # e.g. Debian GNU/Linux
-# Person(s) responsible for this installation
-$gMaintainer = "Local DebBugs Owner"; # e.g. Ian Jackson
-$gMaintainerWebpage = "http://localhost/~owner"; # e.g. http://www.debian.org/~iwj
-$gMaintainerEmail = "root\@something"; # e.g. owner@bugs.debian.org
-$gUnknownMaintainerEmail = "$gMaintainerEmail"; # e.g. unknown-package@qa.debian.org
-
-# BTS mailing lists, at $gListDomain
-# if you don't want lists, set them all to $gMaintainerEmail
-# if you don't want that mail at all, filter it out somehow :)
-$gSubmitList = "bug-submit-list"; # e.g. debian-bugs-dist
-$gMaintList = "bug-maint-list"; # e.g. debian-bugs-dist
-$gQuietList = "bug-quiet-list"; # e.g. debian-bugs-dist
-$gForwardList = "bug-forward-list"; # e.g. debian-bugs-forwarded
-$gDoneList = "bug-done-list"; # e.g. debian-bugs-closed
-$gRequestList = "bug-request-list"; # e.g. debian-bugs-dist
-$gSubmitterList = "bug-submitter-list"; # e.g. debian-bugs-dist
-$gControlList = "bug-control-list"; # e.g. debian-bugs-dist
-$gSummaryList = "bug-summary-list"; # e.g. debian-bugs-reports
-$gMirrorList = "bug-mirrors-list"; # sends to all mirrors
-
-# Various configurable options
-$gMailer = "exim"; # valid: exim, qmail and sendmail
-$gBug = "bug"; # how to spell `bug'
-$gBugs = "bugs"; # how to spell `bugs'
-$gRemoveAge = 28; # days after closed bugs are cleaned out,
- # 0 disables
-$gSaveOldBugs = 1; # whether to archive such bugs
-$gDefaultSeverity = "normal";
-$gShowSeverities = "critical, grave, normal, minor, wishlist";
-@gStrongSeverities = ( 'critical', 'grave' );
-@gSeverityList = ( 'critical', 'grave', 'normal', 'wishlist' );
-%gSeverityDisplay = ( 'critical', "Critical $gBugs",
- 'grave', "Grave $gBugs",
- 'normal', "Normal $gBugs",
- 'wishlist', "Wishlist items" );
-@gTags = ( 'patch', 'wontfix', 'moreinfo', 'unreproducible', 'fixed', 'stable' );
-
-# better don't change this
-$gBounceFroms = "^mailer|^da?emon|^post.*mast|^root|^wpuser|^mmdf|^smt.*|^mrgate|^vmmail|^mail.*system|^uucp|-maiser-|^mal\@|^mail.*agent|^tcpmail|^bitmail|^mailman";
-
-# Directories -- do _not_ change their locations.
-# They are currently hardcoded, variables are here for future expansion.
-$gConfigDir = "/etc/debbugs"; # directory where this file is
-$gSpoolDir = "/var/lib/debbugs/spool"; # working directory
-$gIncomingDir = "incoming"; # unprocessed e-mails
-$gWebDir = "/var/lib/debbugs/www"; # base location of web pages
-$gDocDir = "/var/lib/debbugs/www/txt"; # location of text doc files
-
-# Required data files
-$gMaintainerFile = "$gConfigDir/Maintainers";
-$gMaintainerFileOverride = "$gConfigDir/Maintainers.override";
-$gPseudoDescFile = "$gConfigDir/pseudo-packages.description";
-$gPackageSource = "$gConfigDir/indices/sources";
-
-
-# Estraier Configuration
-%gSearchEstraier = (url => 'http://localhost:1978/node/bts1',
- user => 'user',
- pass => 'pass',
- );
-
-1;
--- /dev/null
+#!/usr/bin/perl
+# $Id: db2html.in,v 1.22 2004/04/19 10:03:53 cjwatson Exp $
+# usage: db2html [-diff] [-stampfile=<stampfile>] [-lastrun=<days>] <wwwbase>
+
+#load the necessary libraries/configuration
+$config_path = '/etc/debbugs';
+$lib_path = '/usr/lib/debbugs';
+
+require("$config_path/config");
+require("$config_path/text");
+require("$lib_path/errorlib");
+$ENV{'PATH'} = $lib_path.':'.$ENV{'PATH'};
+
+use POSIX qw(strftime tzset);
+$ENV{"TZ"} = 'UTC';
+tzset();
+
+#set current working directory
+chdir("$gSpoolDir") || die "chdir spool: $!\n";
+
+#setup variables
+$diff = 0;
+$stampfile = 'stamp.html';
+$tail_html = $gHTMLTail;
+$expirynote_html = '';
+$expirynote_html = $gHTMLExpireNote if $gRemoveAge;
+$shorthead = ' Ref * Package Keywords/Subject Submitter';
+$shortindex = '';
+$amonths = -1;
+$indexunmatched = '';
+%displayshowpendings = ('pending','outstanding',
+ 'done','resolved',
+ 'forwarded','forwarded to upstream software authors');
+
+#set timestamp for html files
+$dtime = strftime "%a, %e %b %Y %T UTC", localtime;
+$tail_html =~ s/SUBSTITUTE_DTIME/$dtime/;
+
+#check for commandline switches
+while (@ARGV && $ARGV[0] =~ m/^-/)
+{ if ($ARGV[0] eq '-diff') { $diff=1; }
+ elsif ($ARGV[0] =~ m/^-lastrun\=([0-9.]+)$/) { $lastrun= $1; undef $stampfile; }
+ elsif ($ARGV[0] =~ m/^-full$/) { undef $lastrun; undef $stampfile; }
+ elsif ($ARGV[0] =~ m/^-stampfile\=(\S+)$/) { $stampfile= $1; }
+ else { die "bad usage"; }
+ shift;
+}
+
+#check for remaing argument, only one...
+@ARGV==1 or die;
+$wwwbase= shift(@ARGV);
+
+#get starting time
+defined($startdate= time) || die "failed to get time: $!";
+
+$|=1;
+
+#if stamp file was given,
+if (defined($stampfile))
+{ if (open(X,"< $stampfile"))
+ { $lastrun= -M X;
+ close(X);
+ printf "progress last run %.7f days\n",$lastrun;
+ } else { print "progress stamp file $stampfile: $! - full\n"; }
+}
+
+#only process file if greater than last run...
+if (defined($lastrun) && -M "db-h" > $lastrun)
+{ $_= $gHTMLStamp;
+ s/SUBSTITUTE_DTIME/$dtime/o;
+ s/\<\!\-\-updateupdate\-\-\>.*\<\!\-\-\/updateupdate\-\-\>/check/;
+ &file('ix/zstamp.html','non',$_."</body></html>\n");
+ print "noremoves";
+# print "db2html: no changes since last run\n";
+ exit 0;
+}
+
+#parse maintainer file
+open(MM,"$gMaintainerFile") || die "open $gMaintainerFile: $!";
+while(<MM>)
+{ m/^(\S+)\s+(\S.*\S)\s*$/ || die "$gMaintainerFile: \`$_'";
+ ($a,$b)=($1,$2);
+ $a =~ y/A-Z/a-z/;
+ $maintainer{$a}= $b;
+}
+close(MM);
+
+#load all database files
+opendir(D,'db-h') || die "opendir db-h: $!";
+@dirs = grep(s#^#db-h/#,grep(/^\d+$/,readdir(D)));
+closedir(D);
+foreach my $dir (@dirs) {
+ opendir(D,$dir);
+ push @files, grep(/^-?\d+\.log$/,readdir(D));
+ closedir(D);
+}
+@files = sort { $a <=> $b } @files;
+
+for $pending (qw(pending done forwarded))
+{ for $severity (@showseverities)
+ { eval "\$index${pending}${severity}= \$iiindex${pending}${severity}= ''; 1;"
+ or die "reset \$index${pending}${severity}: $@";
+ }
+}
+
+for $f (@files)
+{ next unless $f =~ m/^(-?\d+)\.log$/;
+ $ref= $1;
+ #((print STDERR "$ref\n"),
+ #next
+ #)
+ # unless $ref =~ m/^-/ || $ref =~ m/^124/;
+ &filelock("lock/$ref");
+ $preserveonly= defined($lastrun) && -M "db-h/".get_hashname($ref)."/$ref.log" > $lastrun;
+ if ($ref =~ m/^-\d$/)
+ { $week= $ref eq '-1' ? 'this week' :
+ $ref eq '-2' ? 'last week' :
+ $ref eq '-3' ? 'two weeks ago' :
+ ($ref-1)." weeks ago";
+ $linkto= "ju/unmatched$ref";
+ $short= "junk, $week";
+ $descriptivehead=
+ "This includes messages sent to <code>done\@$gEmailDomain</code>\n".
+ "which did not have a $gBug reference number in the Subject line\n".
+ "or which contained an\n".
+ "unknown or out of date $gBug report number (these cause a warning\n".
+ "to be sent to the sender) and details about the messages\n".
+ "sent to <code>request@$gEmailDomain</code> (all of which".
+ "produce replies).\n";
+ $indexlink= "Messages not matched to a specific $gBug report - $week";
+ $data->{subject}= '';
+ $indexentry= '';
+ undef $tpack;
+ undef $tmaint;
+ undef $iiref;
+ $tpackfile= "pnone.html";
+ $indexpart= 'unmatched';
+ } else
+ {
+ $data=readbug($ref);
+ $_= $data->{package}; y/A-Z/a-z/; $_= $` if m/[^-+._a-z0-9()]/;
+ $tpack= $_;
+ if ($data->{severity} eq '' || $data->{severity} eq 'normal')
+ { $showseverity= '';
+ $addseverity= $gDefaultSeverity;
+ } elsif (isstrongseverity($data->{severity}))
+ { $showseverity= "<strong>Severity: $data->{severity}</strong>;\n";
+ $addseverity= $data->{severity};
+ } else
+ { $showseverity= "Severity: <em>$data->{severity}</em>;\n";
+ $addseverity= $data->{severity};
+ }
+ $days= int(($startdate - $data->{date})/86400); close(S);
+ $indexlink= "#$ref: ".&sani($data->{subject});
+ $indexentry= '';
+ $packfile= length($tpack) ? "pa/l$tpack.html" : "pa/none.html";
+ $indexentry .= "Package: <A href=\"../$packfile\"><strong>".
+ &sani($data->{package})."</strong></A>;\n"
+ if length($data->{package});
+ $indexentry .= $showseverity;
+ $indexentry .= "Reported by: ".&sani($data->{originator});
+ $indexentry .= ";\nOwned by: ".&sani($data->{owner})
+ if length($data->{owner});
+ $indexentry .= ";\nKeywords: ".&sani($data->{keywords})
+ if length($data->{keywords});
+ $linkto= $ref; $linkto =~ s,^..,$&/$&,;
+ @merged= split(/ /,$data->{mergedwith});
+ if (@merged)
+ { $mseparator= ";\nmerged with ";
+ for $m (@merged)
+ { $mfile= $m; $mfile =~ s,^..,$&/$&,;
+ $indexentry .= $mseparator."<A href=\"../$mfile.html\">#$m</A>";
+ $mseparator= ",\n";
+ }
+ }
+ $daysold=$submitted='';
+ if (length($data->{done}))
+ { $indexentry .= ";\n<strong>Done:</strong> ".&sani($data->{done});
+ $indexpart= "done$addseverity";
+ } elsif (length($data->{forwarded}))
+ { $indexentry .= ";\n<strong>Forwarded</strong> to ".&sani($data->{forwarded});
+ $indexpart= "forwarded$addseverity";
+ } else
+ { $cmonths= int($days/30);
+ if ($cmonths != $amonths)
+ { $msg= $cmonths == 0 ? "Submitted in the last month" :
+ $cmonths == 1 ? "Over one month old" :
+ $cmonths == 2 ? "Over two months old - attention is required" :
+ "OVER $cmonths MONTHS OLD - ATTENTION IS REQUIRED";
+ $shortindex .= "</pre><h2>$msg:</h2><pre>\n$shorthead\n";
+ $amonths= $cmonths;
+ }
+ $pad= 6-length(sprintf("%d",$f));
+ $thissient=
+ ($pad>0 ? ' 'x$pad : '').
+ sprintf("<A href=\"../%s.html\">%d</A>",$linkto,$ref).
+ &sani(sprintf(" %-1.1s %-10.10s %-35.35s %-.25s\n",
+ $data->{severity},
+ $data->{package},
+ (length($data->{keywords}) ? $data->{keywords}.'/' : '').
+ $data->{subject}, $data->{originator}));
+ $shortindex.= $thissient;
+ $sient{"$ref $data->{package}"}= $thissient;
+ if ($days >= 7)
+ { $font= $days <= 30 ? '' :
+ $days <= 60 ? 'em' :
+ 'strong';
+ $efont= length($font) ? "</$font>" : '';
+ $font= length($font) ? "<$font>" : '';
+ $daysold= "; $font$days days old$efont";
+ }
+ if ($preserveonly) {
+ $submitted = 'THIS IS A BUG IN THE BUG PROCESSOR';
+ } else {
+ $submitted = strftime "%a, %e %b %Y %T %Z", localtime($data->{date});
+ }
+ $submitted= "; dated $submitted";
+ $indexpart= "pending$addseverity";
+ }
+ $iiref= $ref;
+ $short= $ref; $short =~ s/^\d+/#$&/;
+ $tmaint= defined($maintainer{$tpack}) ? $maintainer{$tpack} : '(unknown)';
+ $qpackage= &sani($_);
+ $descriptivehead= $indexentry.$submitted.";\nMaintainer for $qpackage is\n".
+ '<A href="../ma/l'.&maintencoded($tmaint).'.html">'.&sani($tmaint).'</A>.';
+ $indexentry .= $daysold;
+ $indexentry .= ".";
+ }
+ $indexadd='';
+ $indexadd .= "<!--iid $iiref-->" if defined($iiref);
+ $indexadd .= "<li><A href=\"../$linkto.html\">".$indexlink."</A>";
+ $indexadd .= "<br>\n".$indexentry if length($indexentry);
+ $indexadd .= "<!--/iid-->" if defined($iiref);
+ $indexadd .= "\n";
+ $estr= "\$index$indexpart = \$indexadd.\$index$indexpart; 1;";
+ eval($estr) || die "eval add to \$index$indexpart ($estr) failed: $@";
+ #print STDERR ">$estr|$indexadd<\n";
+ $indexadd= "<!--ii $iiref-->\n" if defined($iiref);
+ eval("\$iiindex$indexpart = \$indexadd.\$iiindex$indexpart; 1;") ||
+ die "eval add to \$iiindex$indexpart failed: $@";
+ if (defined($tmaint))
+ { $countpermaint{$tmaint} += length($data->{done}) ? 0 : length($data->{forwarded}) ? 0 : 1;
+ eval("\$permaint${indexpart}{\$tmaint} .= \$indexadd; 1;") ||
+ die "eval add to \$permaint${indexpart}{\$tmaint} failed: $@";
+ }
+ if (defined($tpack))
+ { $countperpack{$tpack} += length($data->{done}) ? 0 : length($data->{forwarded}) ? 0 : 1;
+ eval("\$perpack${indexpart}{\$tpack} .= \$indexadd; 1;") ||
+ die "eval add to \$perpack${indexpart}{\$tpack} failed: $@";
+ }
+ if ($preserveonly) { &preserve("$linkto.html"); &preserve("$linkto-b.html"); &unfilelock; next; }
+ my $hash = get_hashname($ref);
+ open(L,"db-h/$hash/$ref.log") || die "open db-h/$hash/$ref.log: $!";
+ $log='';
+ $boring=''; $xmessage= 0;
+ $normstate= 'kill-init';
+ $suppressnext= 0;
+ while(<L>) {
+ if (m/^\07$/) {
+ $normstate eq 'kill-init' || $normstate eq 'kill-end' ||
+ die "$ref ^G in state $normstate";
+ $normstate= 'incoming-recv';
+ } elsif (m/^\01$/) {
+ $normstate eq 'kill-init' || $normstate eq 'kill-end' ||
+ die "$ref ^A in state $normstate";
+ $normstate= 'autocheck';
+ } elsif (m/^\02$/) {
+ $normstate eq 'kill-init' || $normstate eq 'kill-end' ||
+ die "$ref ^B in state $normstate";
+ $normstate= 'recips';
+ } elsif (m/^\03$/) {
+ $normstate eq 'go' || $normstate eq 'go-nox' || $normstate eq 'html' ||
+ die "$ref ^C in state $normstate";
+ $this .= "</pre>\n" if $normstate eq 'go' || $normstate eq 'go-nox';
+ if ($normstate eq 'html') {
+ $xmessage++;
+ $this .= " <em><A href=\"../$linkto-b.html#m$xmessage\">Full text</A>".
+ " available.</em>";
+ }
+ if ($suppressnext && $normstate ne 'html') {
+ $ntis= $this; $ntis =~ s:\<pre\>:</A><pre>:i;
+ $boring .= "<hr><A name=\"m$xmessage\">\n$ntis\n";
+ } else {
+ $log = $this. "<hr>\n". $log;
+ }
+ $suppressnext= $normstate eq 'html';
+ $normstate= 'kill-end';
+ } elsif (m/^\05$/) {
+ $normstate eq 'kill-body' || die "^E in state $normstate";
+ $this .= "<pre>\n";
+ $normstate= 'go';
+ } elsif (m/^\06$/) {
+ $normstate eq 'kill-init' || $normstate eq 'kill-end' ||
+ die "$ref ^F in state $normstate";
+ $normstate= 'html'; $this= '';
+ } elsif ($normstate eq 'incoming-recv') {
+ $pl= $_; $pl =~ s/\n+$//;
+ m/^Received: \(at (\S+)\) by (\S+)\;/ ||
+ die "bad line \`$pl' in state incoming-recv";
+ $this = "<h2>Message received at ".&sani("$1\@$2").":</h2><br>\n".
+ "<pre>\n".
+ "$_";
+ $normstate= 'go';
+ } elsif ($normstate eq 'html') {
+ $this .= $_;
+ } elsif ($normstate eq 'go') {
+ s/^\030//;
+ $this .= &sani($_);
+ } elsif ($normstate eq 'go-nox') {
+ next if !s/^X//;
+ $this .= &sani($_);
+ } elsif ($normstate eq 'recips') {
+ if (m/^-t$/) {
+ $this = "<h2>Message sent:</h2><br>\n";
+ } else {
+ s/\04/, /g; s/\n$//;
+ $this = "<h2>Message sent to ".&sani($_).":</h2><br>\n";
+ }
+ $normstate= 'kill-body';
+ } elsif ($normstate eq 'autocheck') {
+ next if !m/^X-Debian-Bugs(-\w+)?: This is an autoforward from (\S+)/;
+ $normstate= 'autowait';
+ $this = "<h2>Message received at $2:</h2><br>\n";
+ } elsif ($normstate eq 'autowait') {
+ next if !m/^$/;
+ $normstate= 'go-nox';
+ $this .= "<pre>\n";
+ } else {
+ die "$ref state $normstate line \`$_'";
+ }
+ }
+ die "$ref state $normstate at end" unless $normstate eq 'kill-end';
+ close(L);
+ if (length($boring)) {
+ &file("$linkto-b.html",'non',
+ "<html><head><title>$gProject $gBug report logs - ".
+ "$short, boring messages</title>\n".
+ "<link rev=\"made\" href=\"mailto:$gMaintainerEmail)\">\n".
+ "</head>$gHTMLStart<h1>$gProject $gBugreport logs -".
+ "\n <A href=\"../$linkto.html\">$short</A>,".
+ " boring messages</h1>\n$boring\n<hr>\n".
+ $tail_html."</body></html>\n");
+ }
+ &file("$linkto.html",'non',
+ "<html><head><title>$gProject $gBug report logs - ".
+ "$short</title>\n".
+ "<link rev=\"made\" href=\"mailto:$gMaintainerEmail\">\n".
+ "</head>$gHTMLStart<h1>$gProject $gBug report logs - $short<br>\n".
+ &sani($data->{subject})."</h1>".
+ "$descriptivehead\n".
+ "\n<hr>\n".
+ $log.
+ $tail_html."</body></html>\n");
+ &unfilelock;
+}
+
+sub maintsort {
+ $_= $_[0];
+ s/([^<>()]+) \(([^()<>]+)\)/$2 \<$1\>/;
+
+ s/\s+/ /g;
+ s/^\s*//;
+ $email= s/ *\<[^<>()]+\>$//g ? $& : '';
+ $_= "$1 $_" if s/ (\S+)$//;
+ $_.= $email;
+ $_;
+}
+
+sub maintencoded {
+ return $maintencoded{$_[0]} if defined($maintencoded{$_[0]});
+ local ($input)= @_;
+ local ($todo,$encoded)= ($input);
+ while ($todo =~ m/\W/) {
+ $encoded.=$`.sprintf("-%02x_",unpack("C",$&));
+ $todo= $';
+ }
+ $encoded.= $todo;
+ $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;
+ $maintencoded{$input}= $encoded;
+}
+
+for $tmaint (keys %countpermaint) {
+ $_= $tmaint;
+ $after=$before=$sort2d=$sort2s=$sort1d=$sort1s='';
+ $after= "$&$after" if s/\s*\<[^<>()]+\>\s*$//;
+ $after= "$&$after" if s/\s*\)\s*$//;
+ $after= "$&$after" if s/\s*,.*$//;
+ $before.= $& if s/^.*\(\s*//;
+ $sort2d= $& if s/\S+$//;
+ $sort1d= $_;
+ while (s/^([^()<>]+)\. */$1 /) { };
+ s/\s+$//; y/A-Za-z/a-zA-Z/; $sort1s= $_;
+ $sort2s= $sort2d; $sort2s =~ y/A-Za-z/a-zA-Z/;
+ $maintsort{$tmaint}= $sort2s.' '.$sort1s.' '.$before.$sort1d.$sort2d.$after;
+ $maintdisplay{$tmaint}=
+ &sani($before).'<strong>'.&sani($sort1d.$sort2d).'</strong>'.&sani($after);
+}
+
+sub heading ($$) {
+ my ($pt,$sv) = @_;
+ return $displayshowseverities{$sv}.' - '.$displayshowpendings{$pt};
+}
+
+sub makeindex ($$$) {
+ my ($varprefix,$varsuffix,$tkey) = @_;
+ my ($pending,$severity,$anydone,$text);
+ $anydone= 0;
+ $text= '';
+ for $pending (qw(pending forwarded done)) {
+ for $severity (@showseverities) {
+ $estr= "\$value= \\${varprefix}${pending}${severity}${varsuffix}; 1;";
+#print STDERR $estr;
+ eval $estr
+ or die "eval get \$${varprefix}${pending}${severity} failed: $@";
+#print STDERR ">$$value<\n";
+ next unless length($$value);
+ $text.= "<hr>\n<h2>".&heading($pending,$severity).":</h2>\n".
+ "(List of <A href=\"../si/$pending$severity.html\">all".
+ " such $gBugs</A> is available.)\n<ul>\n".
+ $$value.
+ "</ul>\n";
+ $anydone=1 if $pending eq 'done';
+ }
+ }
+ $text.= $expirynote_html if $anydone;
+ return $text;
+}
+
+&file("ix/full.html",'def',
+ $gFullIndex.
+ makeindex('$index',"",'').
+ "<hr>\n".
+ $tail_html."</body><html>\n");
+
+&file("ju/junk.html",'non',
+ $gJunkIndex.
+ "<hr>\n<h2>Junk (messages without a specific $gBug report number):</h2>\n".
+ "(\`this week' is everything since last Wednesday.)\n<ul>\n".
+ $indexunmatched.
+ "</ul><hr>\n".
+ $tail_html."</body><html>\n");
+
+$nobugs_html= "No reports are currently in this state.";
+$who_html= $gProject;
+$owner_addr= $gMaintainerEmail;
+$otherindex_html= "For other kinds of index or for other information about
+$gProject and the $gBug system, see the <A HREF=\"../../\">$gBug system top-level
+contents WWW page</A>.
+
+";
+
+for $pending (qw(pending forwarded done)) {
+ for $severity (@showseverities) {
+ eval "\$value= \\\$iiindex${pending}${severity}; 1;"
+ or die "eval get \$iiindex${pendingtype}${severity} failed: $@";
+ $value= \$nobugs_html if !length($$value);
+ $headstring= &heading($pending,$severity);
+ &file("si/$pending$severity.html",'ref',
+ "<html><head><title>$who_html $gBug reports: $headstring</title>\n".
+ "<link rev=\"made\" href=\"mailto:".&sani($owner_addr)."\">\n".
+ "</head>$gHTMLStart<h1>$who_html $gBug reports: $headstring</h1>\n".
+ $otherindex_html.
+ ($pending eq 'done' ? "<P>\n$expirynote_html" : '').
+ "<hr>\n<ul>\n".
+ $$value.
+ "</ul>\n<hr>\n".
+ $tail_html."</body></html>\n");
+ }
+}
+
+sub individualindexes ($\@&\%&&$$$$$&&) {
+ my ($filename,$keysref,$getfilenameref,$countref,$getdisplayref,
+ $getsimpledisplayref,$what,$caveat,$whatplural,$abbrev,$ihead,
+ $getxinforef,$getxindexref) = @_;
+ my ($itext,$i,$tkey,$sani,$count,$tfilename,$refto,$backnext,$xitext,$bugbugs);
+ $itext='';
+ for ($i=0; $i<=$#$keysref; $i++) {
+ $tkey= $$keysref[$i];
+ $tfilename= &$getfilenameref($tkey);
+ $sani= &$getsimpledisplayref($tkey);
+ $count= $$countref{$tkey};
+ $count= $count >= 1 ? "$count" : "no";
+ $bugbugs= $count == 1 ? "$gBug" : "$gBugs";
+ $xitext= &$getxindexref($tkey);
+ $xitext= length($xitext) ? "$count $bugbugs; $xitext"
+ : "$count outstanding $bugbugs";
+ $itext .= "<li><A href=\"../$tfilename\">".&$getdisplayref($tkey)."</A>"."\n".
+ " ($xitext)\n";
+ $backnext= '';
+ if ($i>0) {
+ $refto= $$keysref[$i-1];
+ $xitext= &$getxindexref($refto);
+ $xitext= " ($xitext)" if length($xitext);
+ $backnext .= "<br>\nPrevious $what in list, <A href=\"../".
+ &$getfilenameref($refto)."\">".&$getdisplayref($refto)."</A>".
+ "$xitext\n";
+ }
+ if ($i<$#$keysref) {
+ $refto= $$keysref[$i+1];
+ $xitext= &$getxindexref($refto);
+ $xitext= " ($xitext)" if length($xitext);
+ $backnext .= "<br>\nNext $what in list, <A href=\"../".
+ &$getfilenameref($refto)."\">".&$getdisplayref($refto)."</A>".
+ "$xitext\n";
+ }
+ &file($tfilename,'ref',
+ "<html><head><title>$gProject $gBug reports: $what $sani</title>\n".
+ "<link rev=\"made\" href=\"mailto:$gMaintainerEmail\">\n".
+ "</head>$gHTMLStart<h1>$gProject $gBug reports: $what $sani</h1>\n".
+ &$getxinforef($tkey).
+ $caveat.
+ "See the <A href=\"../$filename\">listing of $whatplural</A>.\n".
+ $backnext.
+ &makeindex("\$per${abbrev}","{\$tkey}",$tkey).
+ "<hr>\n".
+ $tail_html."</body></html>\n");
+ }
+ &file($filename,'non',
+ $ihead.
+ "<hr><ul>\n".
+ $itext.
+ "</ul><hr>\n".
+ $tail_html."</body></html>\n");
+}
+
+@maintainers= sort { $maintsort{$a} cmp $maintsort{$b}; } keys %countpermaint;
+individualindexes('ix/maintainers.html',
+ @maintainers,
+ sub { 'ma/l'.&maintencoded($_[0]).'.html'; },
+ %countpermaint,
+ sub { $maintdisplay{$_[0]}; },
+ sub { &sani($_[0]); },
+ 'maintainer',
+ "Note that there may be other reports filed under different
+ variations on the maintainer\'s name and email address.<P>",
+ 'maintainers',
+ 'maint',
+ $gMaintIndex,
+ sub { return ''; },
+ sub { return ''; });
+
+@packages= sort keys %countperpack;
+individualindexes('ix/packages.html',
+ @packages,
+ sub { length($_[0]) ? "pa/l$_[0].html" : 'pa/none.html'; },
+ %countperpack,
+ sub { length($_[0]) ? $_[0] : 'not specified'; },
+ sub { &sani(length($_[0]) ? $_[0] : 'not specified'); },
+ 'package',
+ "Note that with multi-binary packages there may be other
+ reports filed under the different binary package names.<P>",
+ 'packages',
+ 'pack',
+ $gPackageIndex,
+ sub {
+ return unless defined($maintainer{$_[0]});
+ $tmaint= $maintainer{$_[0]};
+ return "Maintainer for $_[0] is <A href=\"../ma/l".
+ &maintencoded($tmaint).
+ ".html\">".&sani($tmaint)."</A>.\n<p>\n";
+ },
+ sub {
+ return unless defined($maintainer{$_[0]});
+ $tmaint= $maintainer{$_[0]};
+ return "<A href=\"../ma/l".
+ &maintencoded($tmaint).
+ ".html\">".&sani($tmaint)."</A>";
+ });
+
+&file('ix/summary.html','non',
+ $gSummaryIndex.
+ "<hr><pre>\n".
+ $shortindex.
+ "</pre><hr>\n".
+ $tail_html."</body></html>\n");
+
+$bypackageindex='';
+for $k (map {$_->[0] }
+ sort { $a->[2] cmp $b->[2] || $a->[1] <=> $b->[1] }
+ map { [$_, split(' ',$_,2)] } keys %sient)
+ { $bypackageindex.= $sient{$k}; }
+&file('ix/psummary.html','non',
+ $gPackageLog.
+ "<hr><pre>\n$shorthead\n".
+ $bypackageindex.
+ "</pre><hr>\n".
+ $tail_html."</body></html>\n");
+
+open(P,"$gPseudoDescFile") ||
+ die "$gPseudoDescFile: $!";
+$ppd=''; while(<P>) { s/\s*\n$//; $ppd.= &sani($_)."\n"; } close(P);
+&file('ix/pseudopackages.html','non',
+ $gPseudoIndex.
+ "<hr><pre>\n$ppd".
+ "</pre><hr>\n".
+ $tail_html."</body></html>\n");
+
+$_= $gHTMLStamp; s/SUBSTITUTE_DTIME/$dtime/o;
+
+&file('ix/zstamp.html','non',$_."</body></html>\n");
+
+sub notimestamp ($) {
+ $_= $_[0];
+ s/\<\!\-\-timestamp\-\-\>\n.*\n\<\!\-\-\/timestamp\-\-\>\n//;
+ return $_;
+}
+
+sub file {
+ local ($name,$ii,$file)= @_;
+ if ($diff) {
+ $cmppath= "$wwwbase/$name".($ii eq 'ref' ? '.ref' : '');
+ if (open(ORIG,"$cmppath")) {
+ undef $/; $orig= <ORIG>; $/= "\n";
+ close(ORIG);
+ if (¬imestamp($orig) eq ¬imestamp($file)) {
+ print "preserve $name\n";
+ return;
+ }
+ defined($c= open(P,"-|")) or die "pipe/fork for diff: $!";
+ if (!$c) {
+ open(Q,"|diff -e $cmppath -") or die "pipe/fork II for diff: $!\n";
+ print Q $file or die "write orig to diff: $!\n";
+ close(Q); $?==0 || $?==256 or die "diff gave $?\n";
+ exit($?>>8);
+ }
+ undef $/; $difftxt= <P>; $/= "\n";
+ close(P); $?==0 || $?==256 or die "diff fork gave $?\n";
+ if ($?==0) {
+ print "preserve $name\n";
+ return;
+ }
+ $v= (split(/\n/,$difftxt));
+ print "diff $v $ii $name\n${difftxt}thatdiff $name\n"
+ or die "stdout (diff): $!";
+ return;
+ }
+ }
+ $v= (split(/\n/,$file));
+ print "file $v $ii $name\n${file}thatfile $name\n" or die "stdout: $!";
+}
+
+sub preserve {
+ print "preserve $_[0]\n";
+}
+
+print "end\n";
+
+while ($u= $cleanups[$#cleanups]) { &$u; }
+exit 0;
+++ /dev/null
-#!/usr/bin/perl
-# $Id: db2html.in,v 1.22 2004/04/19 10:03:53 cjwatson Exp $
-# usage: db2html [-diff] [-stampfile=<stampfile>] [-lastrun=<days>] <wwwbase>
-
-#load the necessary libraries/configuration
-$config_path = '/etc/debbugs';
-$lib_path = '/usr/lib/debbugs';
-
-require("$config_path/config");
-require("$config_path/text");
-require("$lib_path/errorlib");
-$ENV{'PATH'} = $lib_path.':'.$ENV{'PATH'};
-
-use POSIX qw(strftime tzset);
-$ENV{"TZ"} = 'UTC';
-tzset();
-
-#set current working directory
-chdir("$gSpoolDir") || die "chdir spool: $!\n";
-
-#setup variables
-$diff = 0;
-$stampfile = 'stamp.html';
-$tail_html = $gHTMLTail;
-$expirynote_html = '';
-$expirynote_html = $gHTMLExpireNote if $gRemoveAge;
-$shorthead = ' Ref * Package Keywords/Subject Submitter';
-$shortindex = '';
-$amonths = -1;
-$indexunmatched = '';
-%displayshowpendings = ('pending','outstanding',
- 'done','resolved',
- 'forwarded','forwarded to upstream software authors');
-
-#set timestamp for html files
-$dtime = strftime "%a, %e %b %Y %T UTC", localtime;
-$tail_html =~ s/SUBSTITUTE_DTIME/$dtime/;
-
-#check for commandline switches
-while (@ARGV && $ARGV[0] =~ m/^-/)
-{ if ($ARGV[0] eq '-diff') { $diff=1; }
- elsif ($ARGV[0] =~ m/^-lastrun\=([0-9.]+)$/) { $lastrun= $1; undef $stampfile; }
- elsif ($ARGV[0] =~ m/^-full$/) { undef $lastrun; undef $stampfile; }
- elsif ($ARGV[0] =~ m/^-stampfile\=(\S+)$/) { $stampfile= $1; }
- else { &quit("bad usage"); }
- shift;
-}
-
-#check for remaing argument, only one...
-@ARGV==1 or die;
-$wwwbase= shift(@ARGV);
-
-#get starting time
-defined($startdate= time) || &quit("failed to get time: $!");
-
-$|=1;
-
-#if stamp file was given,
-if (defined($stampfile))
-{ if (open(X,"< $stampfile"))
- { $lastrun= -M X;
- close(X);
- printf "progress last run %.7f days\n",$lastrun;
- } else { print "progress stamp file $stampfile: $! - full\n"; }
-}
-
-#only process file if greater than last run...
-if (defined($lastrun) && -M "db-h" > $lastrun)
-{ $_= $gHTMLStamp;
- s/SUBSTITUTE_DTIME/$dtime/o;
- s/\<\!\-\-updateupdate\-\-\>.*\<\!\-\-\/updateupdate\-\-\>/check/;
- &file('ix/zstamp.html','non',$_."</body></html>\n");
- print "noremoves";
-# print "db2html: no changes since last run\n";
- exit 0;
-}
-
-#parse maintainer file
-open(MM,"$gMaintainerFile") || &quit("open $gMaintainerFile: $!");
-while(<MM>)
-{ m/^(\S+)\s+(\S.*\S)\s*$/ || &quit("$gMaintainerFile: \`$_'");
- ($a,$b)=($1,$2);
- $a =~ y/A-Z/a-z/;
- $maintainer{$a}= $b;
-}
-close(MM);
-
-#load all database files
-opendir(D,'db-h') || &quit("opendir db-h: $!");
-@dirs = grep(s#^#db-h/#,grep(/^\d+$/,readdir(D)));
-closedir(D);
-foreach my $dir (@dirs) {
- opendir(D,$dir);
- push @files, grep(/^-?\d+\.log$/,readdir(D));
- closedir(D);
-}
-@files = sort { $a <=> $b } @files;
-
-for $pending (qw(pending done forwarded))
-{ for $severity (@showseverities)
- { eval "\$index${pending}${severity}= \$iiindex${pending}${severity}= ''; 1;"
- or &quit("reset \$index${pending}${severity}: $@");
- }
-}
-
-for $f (@files)
-{ next unless $f =~ m/^(-?\d+)\.log$/;
- $ref= $1;
- #((print STDERR "$ref\n"),
- #next
- #)
- # unless $ref =~ m/^-/ || $ref =~ m/^124/;
- &filelock("lock/$ref");
- $preserveonly= defined($lastrun) && -M "db-h/".get_hashname($ref)."/$ref.log" > $lastrun;
- if ($ref =~ m/^-\d$/)
- { $week= $ref eq '-1' ? 'this week' :
- $ref eq '-2' ? 'last week' :
- $ref eq '-3' ? 'two weeks ago' :
- ($ref-1)." weeks ago";
- $linkto= "ju/unmatched$ref";
- $short= "junk, $week";
- $descriptivehead=
- "This includes messages sent to <code>done\@$gEmailDomain</code>\n".
- "which did not have a $gBug reference number in the Subject line\n".
- "or which contained an\n".
- "unknown or out of date $gBug report number (these cause a warning\n".
- "to be sent to the sender) and details about the messages\n".
- "sent to <code>request@$gEmailDomain</code> (all of which".
- "produce replies).\n";
- $indexlink= "Messages not matched to a specific $gBug report - $week";
- $data->{subject}= '';
- $indexentry= '';
- undef $tpack;
- undef $tmaint;
- undef $iiref;
- $tpackfile= "pnone.html";
- $indexpart= 'unmatched';
- } else
- {
- $data=readbug($ref);
- $_= $data->{package}; y/A-Z/a-z/; $_= $` if m/[^-+._a-z0-9()]/;
- $tpack= $_;
- if ($data->{severity} eq '' || $data->{severity} eq 'normal')
- { $showseverity= '';
- $addseverity= $gDefaultSeverity;
- } elsif (isstrongseverity($data->{severity}))
- { $showseverity= "<strong>Severity: $data->{severity}</strong>;\n";
- $addseverity= $data->{severity};
- } else
- { $showseverity= "Severity: <em>$data->{severity}</em>;\n";
- $addseverity= $data->{severity};
- }
- $days= int(($startdate - $data->{date})/86400); close(S);
- $indexlink= "#$ref: ".&sani($data->{subject});
- $indexentry= '';
- $packfile= length($tpack) ? "pa/l$tpack.html" : "pa/none.html";
- $indexentry .= "Package: <A href=\"../$packfile\"><strong>".
- &sani($data->{package})."</strong></A>;\n"
- if length($data->{package});
- $indexentry .= $showseverity;
- $indexentry .= "Reported by: ".&sani($data->{originator});
- $indexentry .= ";\nOwned by: ".&sani($data->{owner})
- if length($data->{owner});
- $indexentry .= ";\nKeywords: ".&sani($data->{keywords})
- if length($data->{keywords});
- $linkto= $ref; $linkto =~ s,^..,$&/$&,;
- @merged= split(/ /,$data->{mergedwith});
- if (@merged)
- { $mseparator= ";\nmerged with ";
- for $m (@merged)
- { $mfile= $m; $mfile =~ s,^..,$&/$&,;
- $indexentry .= $mseparator."<A href=\"../$mfile.html\">#$m</A>";
- $mseparator= ",\n";
- }
- }
- $daysold=$submitted='';
- if (length($data->{done}))
- { $indexentry .= ";\n<strong>Done:</strong> ".&sani($data->{done});
- $indexpart= "done$addseverity";
- } elsif (length($data->{forwarded}))
- { $indexentry .= ";\n<strong>Forwarded</strong> to ".&sani($data->{forwarded});
- $indexpart= "forwarded$addseverity";
- } else
- { $cmonths= int($days/30);
- if ($cmonths != $amonths)
- { $msg= $cmonths == 0 ? "Submitted in the last month" :
- $cmonths == 1 ? "Over one month old" :
- $cmonths == 2 ? "Over two months old - attention is required" :
- "OVER $cmonths MONTHS OLD - ATTENTION IS REQUIRED";
- $shortindex .= "</pre><h2>$msg:</h2><pre>\n$shorthead\n";
- $amonths= $cmonths;
- }
- $pad= 6-length(sprintf("%d",$f));
- $thissient=
- ($pad>0 ? ' 'x$pad : '').
- sprintf("<A href=\"../%s.html\">%d</A>",$linkto,$ref).
- &sani(sprintf(" %-1.1s %-10.10s %-35.35s %-.25s\n",
- $data->{severity},
- $data->{package},
- (length($data->{keywords}) ? $data->{keywords}.'/' : '').
- $data->{subject}, $data->{originator}));
- $shortindex.= $thissient;
- $sient{"$ref $data->{package}"}= $thissient;
- if ($days >= 7)
- { $font= $days <= 30 ? '' :
- $days <= 60 ? 'em' :
- 'strong';
- $efont= length($font) ? "</$font>" : '';
- $font= length($font) ? "<$font>" : '';
- $daysold= "; $font$days days old$efont";
- }
- if ($preserveonly) {
- $submitted = 'THIS IS A BUG IN THE BUG PROCESSOR';
- } else {
- $submitted = strftime "%a, %e %b %Y %T %Z", localtime($data->{date});
- }
- $submitted= "; dated $submitted";
- $indexpart= "pending$addseverity";
- }
- $iiref= $ref;
- $short= $ref; $short =~ s/^\d+/#$&/;
- $tmaint= defined($maintainer{$tpack}) ? $maintainer{$tpack} : '(unknown)';
- $qpackage= &sani($_);
- $descriptivehead= $indexentry.$submitted.";\nMaintainer for $qpackage is\n".
- '<A href="../ma/l'.&maintencoded($tmaint).'.html">'.&sani($tmaint).'</A>.';
- $indexentry .= $daysold;
- $indexentry .= ".";
- }
- $indexadd='';
- $indexadd .= "<!--iid $iiref-->" if defined($iiref);
- $indexadd .= "<li><A href=\"../$linkto.html\">".$indexlink."</A>";
- $indexadd .= "<br>\n".$indexentry if length($indexentry);
- $indexadd .= "<!--/iid-->" if defined($iiref);
- $indexadd .= "\n";
- $estr= "\$index$indexpart = \$indexadd.\$index$indexpart; 1;";
- eval($estr) || &quit("eval add to \$index$indexpart ($estr) failed: $@");
- #print STDERR ">$estr|$indexadd<\n";
- $indexadd= "<!--ii $iiref-->\n" if defined($iiref);
- eval("\$iiindex$indexpart = \$indexadd.\$iiindex$indexpart; 1;") ||
- &quit("eval add to \$iiindex$indexpart failed: $@");
- if (defined($tmaint))
- { $countpermaint{$tmaint} += length($data->{done}) ? 0 : length($data->{forwarded}) ? 0 : 1;
- eval("\$permaint${indexpart}{\$tmaint} .= \$indexadd; 1;") ||
- &quit("eval add to \$permaint${indexpart}{\$tmaint} failed: $@");
- }
- if (defined($tpack))
- { $countperpack{$tpack} += length($data->{done}) ? 0 : length($data->{forwarded}) ? 0 : 1;
- eval("\$perpack${indexpart}{\$tpack} .= \$indexadd; 1;") ||
- &quit("eval add to \$perpack${indexpart}{\$tpack} failed: $@");
- }
- if ($preserveonly) { &preserve("$linkto.html"); &preserve("$linkto-b.html"); &unfilelock; next; }
- my $hash = get_hashname($ref);
- open(L,"db-h/$hash/$ref.log") || &quit("open db-h/$hash/$ref.log: $!");
- $log='';
- $boring=''; $xmessage= 0;
- $normstate= 'kill-init';
- $suppressnext= 0;
- while(<L>) {
- if (m/^\07$/) {
- $normstate eq 'kill-init' || $normstate eq 'kill-end' ||
- &quit("$ref ^G in state $normstate");
- $normstate= 'incoming-recv';
- } elsif (m/^\01$/) {
- $normstate eq 'kill-init' || $normstate eq 'kill-end' ||
- &quit("$ref ^A in state $normstate");
- $normstate= 'autocheck';
- } elsif (m/^\02$/) {
- $normstate eq 'kill-init' || $normstate eq 'kill-end' ||
- &quit("$ref ^B in state $normstate");
- $normstate= 'recips';
- } elsif (m/^\03$/) {
- $normstate eq 'go' || $normstate eq 'go-nox' || $normstate eq 'html' ||
- &quit("$ref ^C in state $normstate");
- $this .= "</pre>\n" if $normstate eq 'go' || $normstate eq 'go-nox';
- if ($normstate eq 'html') {
- $xmessage++;
- $this .= " <em><A href=\"../$linkto-b.html#m$xmessage\">Full text</A>".
- " available.</em>";
- }
- if ($suppressnext && $normstate ne 'html') {
- $ntis= $this; $ntis =~ s:\<pre\>:</A><pre>:i;
- $boring .= "<hr><A name=\"m$xmessage\">\n$ntis\n";
- } else {
- $log = $this. "<hr>\n". $log;
- }
- $suppressnext= $normstate eq 'html';
- $normstate= 'kill-end';
- } elsif (m/^\05$/) {
- $normstate eq 'kill-body' || &quit("^E in state $normstate");
- $this .= "<pre>\n";
- $normstate= 'go';
- } elsif (m/^\06$/) {
- $normstate eq 'kill-init' || $normstate eq 'kill-end' ||
- &quit("$ref ^F in state $normstate");
- $normstate= 'html'; $this= '';
- } elsif ($normstate eq 'incoming-recv') {
- $pl= $_; $pl =~ s/\n+$//;
- m/^Received: \(at (\S+)\) by (\S+)\;/ ||
- &quit("bad line \`$pl' in state incoming-recv");
- $this = "<h2>Message received at ".&sani("$1\@$2").":</h2><br>\n".
- "<pre>\n".
- "$_";
- $normstate= 'go';
- } elsif ($normstate eq 'html') {
- $this .= $_;
- } elsif ($normstate eq 'go') {
- s/^\030//;
- $this .= &sani($_);
- } elsif ($normstate eq 'go-nox') {
- next if !s/^X//;
- $this .= &sani($_);
- } elsif ($normstate eq 'recips') {
- if (m/^-t$/) {
- $this = "<h2>Message sent:</h2><br>\n";
- } else {
- s/\04/, /g; s/\n$//;
- $this = "<h2>Message sent to ".&sani($_).":</h2><br>\n";
- }
- $normstate= 'kill-body';
- } elsif ($normstate eq 'autocheck') {
- next if !m/^X-Debian-Bugs(-\w+)?: This is an autoforward from (\S+)/;
- $normstate= 'autowait';
- $this = "<h2>Message received at $2:</h2><br>\n";
- } elsif ($normstate eq 'autowait') {
- next if !m/^$/;
- $normstate= 'go-nox';
- $this .= "<pre>\n";
- } else {
- &quit("$ref state $normstate line \`$_'");
- }
- }
- &quit("$ref state $normstate at end") unless $normstate eq 'kill-end';
- close(L);
- if (length($boring)) {
- &file("$linkto-b.html",'non',
- "<html><head><title>$gProject $gBug report logs - ".
- "$short, boring messages</title>\n".
- "<link rev=\"made\" href=\"mailto:$gMaintainerEmail)\">\n".
- "</head>$gHTMLStart<h1>$gProject $gBugreport logs -".
- "\n <A href=\"../$linkto.html\">$short</A>,".
- " boring messages</h1>\n$boring\n<hr>\n".
- $tail_html."</body></html>\n");
- }
- &file("$linkto.html",'non',
- "<html><head><title>$gProject $gBug report logs - ".
- "$short</title>\n".
- "<link rev=\"made\" href=\"mailto:$gMaintainerEmail\">\n".
- "</head>$gHTMLStart<h1>$gProject $gBug report logs - $short<br>\n".
- &sani($data->{subject})."</h1>".
- "$descriptivehead\n".
- "\n<hr>\n".
- $log.
- $tail_html."</body></html>\n");
- &unfilelock;
-}
-
-sub maintsort {
- $_= $_[0];
- s/([^<>()]+) \(([^()<>]+)\)/$2 \<$1\>/;
-
- s/\s+/ /g;
- s/^\s*//;
- $email= s/ *\<[^<>()]+\>$//g ? $& : '';
- $_= "$1 $_" if s/ (\S+)$//;
- $_.= $email;
- $_;
-}
-
-sub maintencoded {
- return $maintencoded{$_[0]} if defined($maintencoded{$_[0]});
- local ($input)= @_;
- local ($todo,$encoded)= ($input);
- while ($todo =~ m/\W/) {
- $encoded.=$`.sprintf("-%02x_",unpack("C",$&));
- $todo= $';
- }
- $encoded.= $todo;
- $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;
- $maintencoded{$input}= $encoded;
-}
-
-for $tmaint (keys %countpermaint) {
- $_= $tmaint;
- $after=$before=$sort2d=$sort2s=$sort1d=$sort1s='';
- $after= "$&$after" if s/\s*\<[^<>()]+\>\s*$//;
- $after= "$&$after" if s/\s*\)\s*$//;
- $after= "$&$after" if s/\s*,.*$//;
- $before.= $& if s/^.*\(\s*//;
- $sort2d= $& if s/\S+$//;
- $sort1d= $_;
- while (s/^([^()<>]+)\. */$1 /) { };
- s/\s+$//; y/A-Za-z/a-zA-Z/; $sort1s= $_;
- $sort2s= $sort2d; $sort2s =~ y/A-Za-z/a-zA-Z/;
- $maintsort{$tmaint}= $sort2s.' '.$sort1s.' '.$before.$sort1d.$sort2d.$after;
- $maintdisplay{$tmaint}=
- &sani($before).'<strong>'.&sani($sort1d.$sort2d).'</strong>'.&sani($after);
-}
-
-sub heading ($$) {
- my ($pt,$sv) = @_;
- return $displayshowseverities{$sv}.' - '.$displayshowpendings{$pt};
-}
-
-sub makeindex ($$$) {
- my ($varprefix,$varsuffix,$tkey) = @_;
- my ($pending,$severity,$anydone,$text);
- $anydone= 0;
- $text= '';
- for $pending (qw(pending forwarded done)) {
- for $severity (@showseverities) {
- $estr= "\$value= \\${varprefix}${pending}${severity}${varsuffix}; 1;";
-#print STDERR $estr;
- eval $estr
- or &quit("eval get \$${varprefix}${pending}${severity} failed: $@");
-#print STDERR ">$$value<\n";
- next unless length($$value);
- $text.= "<hr>\n<h2>".&heading($pending,$severity).":</h2>\n".
- "(List of <A href=\"../si/$pending$severity.html\">all".
- " such $gBugs</A> is available.)\n<ul>\n".
- $$value.
- "</ul>\n";
- $anydone=1 if $pending eq 'done';
- }
- }
- $text.= $expirynote_html if $anydone;
- return $text;
-}
-
-&file("ix/full.html",'def',
- $gFullIndex.
- makeindex('$index',"",'').
- "<hr>\n".
- $tail_html."</body><html>\n");
-
-&file("ju/junk.html",'non',
- $gJunkIndex.
- "<hr>\n<h2>Junk (messages without a specific $gBug report number):</h2>\n".
- "(\`this week' is everything since last Wednesday.)\n<ul>\n".
- $indexunmatched.
- "</ul><hr>\n".
- $tail_html."</body><html>\n");
-
-$nobugs_html= "No reports are currently in this state.";
-$who_html= $gProject;
-$owner_addr= $gMaintainerEmail;
-$otherindex_html= "For other kinds of index or for other information about
-$gProject and the $gBug system, see the <A HREF=\"../../\">$gBug system top-level
-contents WWW page</A>.
-
-";
-
-for $pending (qw(pending forwarded done)) {
- for $severity (@showseverities) {
- eval "\$value= \\\$iiindex${pending}${severity}; 1;"
- or &quit("eval get \$iiindex${pendingtype}${severity} failed: $@");
- $value= \$nobugs_html if !length($$value);
- $headstring= &heading($pending,$severity);
- &file("si/$pending$severity.html",'ref',
- "<html><head><title>$who_html $gBug reports: $headstring</title>\n".
- "<link rev=\"made\" href=\"mailto:".&sani($owner_addr)."\">\n".
- "</head>$gHTMLStart<h1>$who_html $gBug reports: $headstring</h1>\n".
- $otherindex_html.
- ($pending eq 'done' ? "<P>\n$expirynote_html" : '').
- "<hr>\n<ul>\n".
- $$value.
- "</ul>\n<hr>\n".
- $tail_html."</body></html>\n");
- }
-}
-
-sub individualindexes ($\@&\%&&$$$$$&&) {
- my ($filename,$keysref,$getfilenameref,$countref,$getdisplayref,
- $getsimpledisplayref,$what,$caveat,$whatplural,$abbrev,$ihead,
- $getxinforef,$getxindexref) = @_;
- my ($itext,$i,$tkey,$sani,$count,$tfilename,$refto,$backnext,$xitext,$bugbugs);
- $itext='';
- for ($i=0; $i<=$#$keysref; $i++) {
- $tkey= $$keysref[$i];
- $tfilename= &$getfilenameref($tkey);
- $sani= &$getsimpledisplayref($tkey);
- $count= $$countref{$tkey};
- $count= $count >= 1 ? "$count" : "no";
- $bugbugs= $count == 1 ? "$gBug" : "$gBugs";
- $xitext= &$getxindexref($tkey);
- $xitext= length($xitext) ? "$count $bugbugs; $xitext"
- : "$count outstanding $bugbugs";
- $itext .= "<li><A href=\"../$tfilename\">".&$getdisplayref($tkey)."</A>"."\n".
- " ($xitext)\n";
- $backnext= '';
- if ($i>0) {
- $refto= $$keysref[$i-1];
- $xitext= &$getxindexref($refto);
- $xitext= " ($xitext)" if length($xitext);
- $backnext .= "<br>\nPrevious $what in list, <A href=\"../".
- &$getfilenameref($refto)."\">".&$getdisplayref($refto)."</A>".
- "$xitext\n";
- }
- if ($i<$#$keysref) {
- $refto= $$keysref[$i+1];
- $xitext= &$getxindexref($refto);
- $xitext= " ($xitext)" if length($xitext);
- $backnext .= "<br>\nNext $what in list, <A href=\"../".
- &$getfilenameref($refto)."\">".&$getdisplayref($refto)."</A>".
- "$xitext\n";
- }
- &file($tfilename,'ref',
- "<html><head><title>$gProject $gBug reports: $what $sani</title>\n".
- "<link rev=\"made\" href=\"mailto:$gMaintainerEmail\">\n".
- "</head>$gHTMLStart<h1>$gProject $gBug reports: $what $sani</h1>\n".
- &$getxinforef($tkey).
- $caveat.
- "See the <A href=\"../$filename\">listing of $whatplural</A>.\n".
- $backnext.
- &makeindex("\$per${abbrev}","{\$tkey}",$tkey).
- "<hr>\n".
- $tail_html."</body></html>\n");
- }
- &file($filename,'non',
- $ihead.
- "<hr><ul>\n".
- $itext.
- "</ul><hr>\n".
- $tail_html."</body></html>\n");
-}
-
-@maintainers= sort { $maintsort{$a} cmp $maintsort{$b}; } keys %countpermaint;
-individualindexes('ix/maintainers.html',
- @maintainers,
- sub { 'ma/l'.&maintencoded($_[0]).'.html'; },
- %countpermaint,
- sub { $maintdisplay{$_[0]}; },
- sub { &sani($_[0]); },
- 'maintainer',
- "Note that there may be other reports filed under different
- variations on the maintainer\'s name and email address.<P>",
- 'maintainers',
- 'maint',
- $gMaintIndex,
- sub { return ''; },
- sub { return ''; });
-
-@packages= sort keys %countperpack;
-individualindexes('ix/packages.html',
- @packages,
- sub { length($_[0]) ? "pa/l$_[0].html" : 'pa/none.html'; },
- %countperpack,
- sub { length($_[0]) ? $_[0] : 'not specified'; },
- sub { &sani(length($_[0]) ? $_[0] : 'not specified'); },
- 'package',
- "Note that with multi-binary packages there may be other
- reports filed under the different binary package names.<P>",
- 'packages',
- 'pack',
- $gPackageIndex,
- sub {
- return unless defined($maintainer{$_[0]});
- $tmaint= $maintainer{$_[0]};
- return "Maintainer for $_[0] is <A href=\"../ma/l".
- &maintencoded($tmaint).
- ".html\">".&sani($tmaint)."</A>.\n<p>\n";
- },
- sub {
- return unless defined($maintainer{$_[0]});
- $tmaint= $maintainer{$_[0]};
- return "<A href=\"../ma/l".
- &maintencoded($tmaint).
- ".html\">".&sani($tmaint)."</A>";
- });
-
-&file('ix/summary.html','non',
- $gSummaryIndex.
- "<hr><pre>\n".
- $shortindex.
- "</pre><hr>\n".
- $tail_html."</body></html>\n");
-
-$bypackageindex='';
-for $k (map {$_->[0] }
- sort { $a->[2] cmp $b->[2] || $a->[1] <=> $b->[1] }
- map { [$_, split(' ',$_,2)] } keys %sient)
- { $bypackageindex.= $sient{$k}; }
-&file('ix/psummary.html','non',
- $gPackageLog.
- "<hr><pre>\n$shorthead\n".
- $bypackageindex.
- "</pre><hr>\n".
- $tail_html."</body></html>\n");
-
-open(P,"$gPseudoDescFile") ||
- &quit("$gPseudoDescFile: $!");
-$ppd=''; while(<P>) { s/\s*\n$//; $ppd.= &sani($_)."\n"; } close(P);
-&file('ix/pseudopackages.html','non',
- $gPseudoIndex.
- "<hr><pre>\n$ppd".
- "</pre><hr>\n".
- $tail_html."</body></html>\n");
-
-$_= $gHTMLStamp; s/SUBSTITUTE_DTIME/$dtime/o;
-
-&file('ix/zstamp.html','non',$_."</body></html>\n");
-
-sub notimestamp ($) {
- $_= $_[0];
- s/\<\!\-\-timestamp\-\-\>\n.*\n\<\!\-\-\/timestamp\-\-\>\n//;
- return $_;
-}
-
-sub file {
- local ($name,$ii,$file)= @_;
- if ($diff) {
- $cmppath= "$wwwbase/$name".($ii eq 'ref' ? '.ref' : '');
- if (open(ORIG,"$cmppath")) {
- undef $/; $orig= <ORIG>; $/= "\n";
- close(ORIG);
- if (¬imestamp($orig) eq ¬imestamp($file)) {
- print "preserve $name\n";
- return;
- }
- defined($c= open(P,"-|")) or &quit("pipe/fork for diff: $!");
- if (!$c) {
- open(Q,"|diff -e $cmppath -") or die "pipe/fork II for diff: $!\n";
- print Q $file or die "write orig to diff: $!\n";
- close(Q); $?==0 || $?==256 or die "diff gave $?\n";
- exit($?>>8);
- }
- undef $/; $difftxt= <P>; $/= "\n";
- close(P); $?==0 || $?==256 or die "diff fork gave $?\n";
- if ($?==0) {
- print "preserve $name\n";
- return;
- }
- $v= (split(/\n/,$difftxt));
- print "diff $v $ii $name\n${difftxt}thatdiff $name\n"
- or &quit("stdout (diff): $!");
- return;
- }
- }
- $v= (split(/\n/,$file));
- print "file $v $ii $name\n${file}thatfile $name\n" or &quit("stdout: $!");
-}
-
-sub preserve {
- print "preserve $_[0]\n";
-}
-
-print "end\n";
-
-while ($u= $cleanups[$#cleanups]) { &$u; }
-exit 0;
--- /dev/null
+# -*- perl -*-
+
+use Mail::Address;
+use Debbugs::MIME qw(decode_rfc1522 encode_rfc1522 getmailbody);
+use Debbugs::Packages qw(:all);
+use Debbugs::Common qw(:all);
+use Debbugs::Status qw(:all);
+use Carp;
+
+sub unlockreadbugmerge {
+ local ($rv) = @_;
+ &unfilelock if $rv >= 2;
+ &unfilelock if $rv >= 1;
+}
+
+%saniarray= ('<','lt', '>','gt', '&','amp', '"','quot');
+
+sub sani {
+ my ($in) = @_;
+ carp "You should be using HTML::Entities instead.";
+ $in =~ s/([<>&"])/$saniarray{$1}/g;
+ return $in;
+}
+
+sub get_addresses {
+ return
+ map { $_->address() }
+ map { Mail::Address->parse($_) } @_;
+}
+
+@severities= grep { not exists $gObsoleteSeverities{$_} } @gSeverityList;
+@showseverities= @severities;
+grep ($_= $_ eq '' ? $gDefaultSeverity : $_, @showseverities);
+%displayshowseverities= %gSeverityDisplay;
+
+# compatibility
+if (defined $gFowardList and not defined $gForwardList) {
+ $gForwardList = $gFowardList;
+}
+
+1;
+++ /dev/null
-# -*- perl -*-
-
-use Mail::Address;
-use Debbugs::MIME qw(decode_rfc1522 encode_rfc1522 getmailbody);
-use Debbugs::Packages qw(:all);
-use Debbugs::Common qw(:all);
-use Debbugs::Status qw(:all);
-use Carp;
-
-sub unlockreadbugmerge {
- local ($rv) = @_;
- &unfilelock if $rv >= 2;
- &unfilelock if $rv >= 1;
-}
-
-%saniarray= ('<','lt', '>','gt', '&','amp', '"','quot');
-
-sub sani {
- my ($in) = @_;
- carp "You should be using HTML::Entities instead.";
- $in =~ s/([<>&"])/$saniarray{$1}/g;
- return $in;
-}
-
-sub get_addresses {
- return
- map { $_->address() }
- map { Mail::Address->parse($_) } @_;
-}
-
-@severities= grep { not exists $gObsoleteSeverities{$_} } @gSeverityList;
-@showseverities= @severities;
-grep ($_= $_ eq '' ? $gDefaultSeverity : $_, @showseverities);
-%displayshowseverities= %gSeverityDisplay;
-
-# compatibility
-if (defined $gFowardList and not defined $gForwardList) {
- $gForwardList = $gFowardList;
-}
-
-1;
--- /dev/null
+#!/usr/bin/perl
+# This script 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.
+#
+# [Other people may have contributed to this file; their copyrights
+# should go here too.]
+# Copyright 2004 by Collin Watson <cjwatson@debian.org>
+# Copyright 2007 by Don Armstrong <don@donarmstrong.com>
+
+use Getopt::Long;
+use Pod::Usage;
+
+use warnings;
+use strict;
+
+=head1 NAME
+
+expire - Expires archiveable bugs by copying to archive or deleting
+
+=head1 SYNOPSIS
+
+ expire [options]
+
+ Options:
+ --debug, -d debugging level (Default 0)
+ --help, -h display this help
+ --man, -m display manual
+
+=head1 OPTIONS
+
+=over
+
+=item B<--debug, -d>
+
+Debug verbosity. (Default 0)
+
+=item B<--help, -h>
+
+Display brief useage information.
+
+=item B<--man, -m>
+
+Display this manual.
+
+=back
+
+=head1 EXAMPLES
+
+
+=cut
+
+my %options = (debug => 0,
+ help => 0,
+ man => 0,
+ quick => 0,
+ index_path => undef,
+ );
+
+GetOptions(\%options,'debug|d+','help|h|?','man|m') or pod2usage(2);
+pod2usage(1) if $options{help};
+pod2usage(-verbose=>2) if $options{man};
+
+
+my $verbose = $options{debug};
+
+use Debbugs::Control qw(bug_archive);
+use Debbugs::Status qw(bug_archiveable);
+
+use Debbugs::Config qw(:config);
+use Debbugs::Common qw(:lock);
+
+# No $gRemoveAge means "never expire".
+exit 0 unless $config{remove_age};
+
+chdir($config{spool_dir}) || die "chdir $config{spool_dir} failed: $!\n";
+
+#get list of bugs (ie, status files)
+opendir(DIR,"db-h") or die "Unable to open dir db-h: $!";
+my @dirs = sort { $a cmp $b } grep(s,^,db-h/,, grep(m/^\d+$/,readdir(DIR)));
+close(DIR);
+my @list;
+foreach my $dir (@dirs) {
+ opendir(DIR,$dir);
+ push @list, sort { $a <=> $b } grep(s/\.summary$//,grep(m/^\d+\.summary$/,readdir(DIR)));
+ close(DIR);
+}
+
+my $bug;
+my $errors=0;
+our $exit_now = 0;
+#process each bug (ie, status file)
+my @bugs_to_archive = ();
+for my $bug (@list) {
+ # Weeeee.
+ print "Examining $bug\n" if $verbose;
+ next unless bug_archiveable(bug=>$bug);
+ push @bugs_to_archive,$bug;
+}
+
+$SIG{INT} = sub {$exit_now=1;};
+# At this point we want to block control
+if (not lockpid($config{spool_dir}.'/lock/expire.pid')) {
+ exit 1;
+}
+# We'll also double check that the bug can be archived
+for my $bug (@bugs_to_archive) {
+ last if $exit_now;
+ print "Reexamining $bug\n" if $verbose;
+ next unless bug_archiveable(bug=>$bug);
+ last if $exit_now;
+ print "Bug $bug can be archived: " if $verbose;
+ eval {
+ bug_archive(bug=>$bug,
+ );
+ print "archived.\n" if $verbose;
+ };
+ if ($@) {
+ $errors=1;
+ print "failed.\n" if $verbose;
+ print STDERR "Unable to archive bug# $bug which I thought I could archive:\n$@\n";
+ }
+ last if $exit_now;
+}
+unlink($config{spool_dir}.'/lock/expire.pid');
+
+
+exit $errors;
+++ /dev/null
-#!/usr/bin/perl
-# This script 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.
-#
-# [Other people may have contributed to this file; their copyrights
-# should go here too.]
-# Copyright 2004 by Collin Watson <cjwatson@debian.org>
-# Copyright 2007 by Don Armstrong <don@donarmstrong.com>
-
-use Getopt::Long;
-use Pod::Usage;
-
-use warnings;
-use strict;
-
-=head1 NAME
-
-expire - Expires archiveable bugs by copying to archive or deleting
-
-=head1 SYNOPSIS
-
- expire [options]
-
- Options:
- --debug, -d debugging level (Default 0)
- --help, -h display this help
- --man, -m display manual
-
-=head1 OPTIONS
-
-=over
-
-=item B<--debug, -d>
-
-Debug verbosity. (Default 0)
-
-=item B<--help, -h>
-
-Display brief useage information.
-
-=item B<--man, -m>
-
-Display this manual.
-
-=back
-
-=head1 EXAMPLES
-
-
-=cut
-
-my %options = (debug => 0,
- help => 0,
- man => 0,
- quick => 0,
- index_path => undef,
- );
-
-GetOptions(\%options,'debug|d+','help|h|?','man|m') or pod2usage(2);
-pod2usage(1) if $options{help};
-pod2usage(-verbose=>2) if $options{man};
-
-
-my $verbose = $options{debug};
-
-use Debbugs::Control qw(bug_archive);
-use Debbugs::Status qw(bug_archiveable);
-
-use Debbugs::Config qw(:config);
-use Debbugs::Common qw(:lock);
-
-# No $gRemoveAge means "never expire".
-exit 0 unless $config{remove_age};
-
-chdir($config{spool_dir}) || die "chdir $config{spool_dir} failed: $!\n";
-
-#get list of bugs (ie, status files)
-opendir(DIR,"db-h") or die "Unable to open dir db-h: $!";
-my @dirs = sort { $a cmp $b } grep(s,^,db-h/,, grep(m/^\d+$/,readdir(DIR)));
-close(DIR);
-my @list;
-foreach my $dir (@dirs) {
- opendir(DIR,$dir);
- push @list, sort { $a <=> $b } grep(s/\.summary$//,grep(m/^\d+\.summary$/,readdir(DIR)));
- close(DIR);
-}
-
-my $bug;
-my $errors=0;
-our $exit_now = 0;
-#process each bug (ie, status file)
-my @bugs_to_archive = ();
-for my $bug (@list) {
- # Weeeee.
- print "Examining $bug\n" if $verbose;
- next unless bug_archiveable(bug=>$bug);
- push @bugs_to_archive,$bug;
-}
-
-$SIG{INT} = sub {$exit_now=1;};
-# At this point we want to block control
-if (not lockpid($config{spool_dir}.'/lock/expire.pid')) {
- exit 1;
-}
-# We'll also double check that the bug can be archived
-for my $bug (@bugs_to_archive) {
- last if $exit_now;
- print "Reexamining $bug\n" if $verbose;
- next unless bug_archiveable(bug=>$bug);
- last if $exit_now;
- print "Bug $bug can be archived: " if $verbose;
- eval {
- bug_archive(bug=>$bug,
- );
- print "archived.\n" if $verbose;
- };
- if ($@) {
- $errors=1;
- print "failed.\n" if $verbose;
- print STDERR "Unable to archive bug# $bug which I thought I could archive:\n$@\n";
- }
- last if $exit_now;
-}
-unlink($config{spool_dir}.'/lock/expire.pid');
-
-
-exit $errors;
--- /dev/null
+#!/usr/bin/perl
+# gen-indices generates bug index files, 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 (c) 2005/08/03 Anthony Towns
+# Copyright 2007, 2008 by Don Armstrong <don@donarmstrong.com>.
+
+use warnings;
+use strict;
+
+use DB_File;
+use MLDBM qw(DB_FILE Storable);
+use Fcntl qw/O_RDWR O_CREAT O_TRUNC/;
+use File::Copy;
+
+use Getopt::Long;
+use Pod::Usage;
+
+use File::stat;
+use List::Util qw(min);
+
+=head1 NAME
+
+gen-indices - Generates index files for the cgi scripts
+
+=head1 SYNOPSIS
+
+ gen-indices [options]
+
+ Options:
+ --index-path path to index location
+ --quick update changed bugs
+ --debug, -d debugging level (Default 0)
+ --help, -h display this help
+ --man, -m display manual
+
+=head1 OPTIONS
+
+=over
+
+=itme B<--quick>
+
+Only update changed bugs
+
+=item B<--debug, -d>
+
+Debug verbosity. (Default 0)
+
+=item B<--help, -h>
+
+Display brief useage information.
+
+=item B<--man, -m>
+
+Display this manual.
+
+=back
+
+=head1 EXAMPLES
+
+
+=cut
+
+# Use portable Storable images
+$MLDBM::DumpMeth=q(portable);
+
+
+my %options = (debug => 0,
+ help => 0,
+ man => 0,
+ quick => 0,
+ index_path => undef,
+ );
+
+GetOptions(\%options,'quick!','index_path|index-path=s','debug|d+','help|h|?','man|m') or pod2usage(2);
+pod2usage(1) if $options{help};
+pod2usage(-verbose=>2) if $options{man};
+
+use Debbugs::Config qw(:config);
+use Debbugs::Common qw(getparsedaddrs getbugcomponent lockpid);
+use Debbugs::Status qw(readbug);
+use Debbugs::Log;
+
+chdir($config{spool_dir}) or die "chdir $config{spool_dir} failed: $!";
+
+my $verbose = $options{debug};
+my $indexdest = $options{index_path} || $config{spool_dir};
+
+my $initialdir = "db-h";
+my $suffix = "";
+
+if (defined $ARGV[0] and $ARGV[0] eq "archive") {
+ $initialdir = "archive";
+ $suffix = "-arc";
+}
+
+if (not lockpid($config{spool_dir}.'/lock/gen-indices')) {
+ if ($options{quick}) {
+ # If this is a quick run, just exit
+ print STDERR "Another gen-indices is running; stopping\n" if $verbose;
+ exit 0;
+ }
+ print STDERR "Another gen-indices is running; stopping\n";
+ exit 1;
+}
+
+# NB: The reverse index is special; it's used to clean up during updates to bugs
+my @indexes = ('package', 'tag', 'severity','owner','submitter-email','status','correspondent','reverse');
+my $indexes;
+my %slow_index = ();
+my %fast_index = ();
+if (not $options{quick}) {
+ # We'll trade memory for speed here if we're not doing a quick rebuild
+ for my $indexes (@indexes) {
+ $fast_index{$indexes} = {};
+ }
+ $indexes = \%fast_index;
+}
+else {
+ $indexes = \%slow_index;
+}
+my $time = undef;
+my $start_time = time;
+for my $i (@indexes) {
+ $slow_index{$i} = {};
+ if ($options{quick}) {
+ if (-e "$indexdest/by-$i${suffix}.idx") {
+ system('cp','-a',"$indexdest/by-$i${suffix}.idx","$indexdest/by-$i${suffix}.idx.new") == 0
+ or die "Error creating the new index";
+ my $stat = stat("$indexdest/by-$i${suffix}.idx") or die "Unable to stat $indexdest/by-$i${suffix}.idx";
+ $time = defined $time ? min($time,$stat->mtime) : $stat->mtime;
+ }
+ tie %{$slow_index{$i}}, MLDBM => "$indexdest/by-$i$suffix.idx.new",
+ O_RDWR|O_CREAT, 0666
+ or die "$0: can't create by-$i$suffix-idx.new: $!";
+ }
+ else {
+ tie %{$slow_index{$i}}, MLDBM => "$indexdest/by-$i$suffix.idx.new",
+ O_RDWR|O_CREAT|O_TRUNC, 0666
+ or die "$0: can't create by-$i$suffix-idx.new: $!";
+
+ }
+ $time = 0 if not defined $time;
+}
+
+sub addbugtoindex {
+ my ($index, $bug, @values) = @_;
+
+ if (exists $indexes->{reverse}{"$index $bug"}) {
+ # We do this insanity to work around a "feature" in MLDBM
+ for my $key (@{$indexes->{reverse}{"$index $bug"}}) {
+ my $temp = $indexes->{$index}{$key};
+ delete $temp->{$bug};
+ $indexes->{$index}{$key} = $temp;
+ $indexes->{$index}{"count $key"}--;
+ }
+ delete $indexes->{reverse}{"$index $bug"};
+ }
+ for my $key (@values) {
+ $indexes->{$index}->{"count $key"}++;
+ # We do this insanity to work around a "feature" in MLDBM
+ my $temp = $indexes->{$index}->{$key};
+ $temp->{$bug} = 1;
+ $indexes->{$index}->{$key} = $temp;
+ }
+ $indexes->{reverse}{"$index $bug"} = [@values];
+}
+
+sub emailfromrfc822 {
+ my $email = shift;
+ $email =~ s/\s*\(.*\)\s*//;
+ $email = $1 if ($email =~ m/<(.*)>/);
+ return $email;
+}
+
+my $cnt = 0;
+
+my @dirs = ($initialdir);
+while (my $dir = shift @dirs) {
+ printf "Doing dir %s ...\n", $dir if $verbose;
+
+ opendir(DIR, "$dir/.") or die "opendir $dir: $!";
+ my @subdirs = readdir(DIR);
+ closedir(DIR);
+
+ my @list = map { m/^(\d+)\.summary$/?($1):() } @subdirs;
+ push @dirs, map { m/^(\d+)$/ && -d "$dir/$1"?("$dir/$1"):() } @subdirs;
+
+ for my $bug (@list) {
+ print "Up to $cnt bugs...\n" if (++$cnt % 100 == 0 && $verbose);
+ my $stat = stat(getbugcomponent($bug,'summary',$initialdir));
+ if (not defined $stat) {
+ print STDERR "Unable to stat $bug $!\n";
+ next;
+ }
+ next if $stat->mtime < $time;
+ my $fdata = readbug($bug, $initialdir);
+ addbugtoindex("package", $bug, split /[\s,]+/, $fdata->{"package"});
+ addbugtoindex("tag", $bug, split /[\s,]+/, $fdata->{"keywords"});
+ addbugtoindex('submitter-email', $bug,
+ map {lc($_->address)} getparsedaddrs($fdata->{originator}));
+ addbugtoindex("severity", $bug, $fdata->{"severity"});
+ addbugtoindex("owner", $bug,
+ map {lc($_->address)} getparsedaddrs($fdata->{"owner"}));
+ # handle log entries
+ # do this in eval to avoid exploding on jacked logs
+ eval {
+ my $log = Debbugs::Log->new(bug_num => $bug);
+ while (my $record = $log->read_record()) {
+ next unless $record->{type} eq 'incoming-recv';
+ # we use a regex here, because a full mime parse will be slow.
+ my ($from) = $record->{text} =~ /^From:\s+(.+?)^\S/ism;
+ addbugtoindex('correspondent',$bug,
+ map {lc($_->address)} getparsedaddrs($from)
+ );
+ }
+ };
+ if ($@) {
+ print STDERR "Problem dealing with log of $bug: $@";
+ }
+ }
+}
+
+if (not $options{quick}) {
+ # put the fast index into the slow index
+ for my $key1 (keys %fast_index) {
+ for my $key2 (keys %{$fast_index{$key1}}) {
+ $slow_index{$key1}{$key2} = $fast_index{$key1}{$key2};
+ }
+ print "Dealt with index $key1\n" if $verbose;
+ }
+}
+
+
+for my $i (@indexes) {
+ untie %{$slow_index{$i}};
+ move("$indexdest/by-$i$suffix.idx.new", "$indexdest/by-$i$suffix.idx");
+ # We do this, because old versions of touch don't support -d '@epoch'
+ system('touch','-d',"1/1/1970 UTC + ${start_time}secs","$indexdest/by-$i$suffix.idx");
+}
+
+unlink($config{spool_dir}.'/lock/gen-indices')
+++ /dev/null
-#!/usr/bin/perl
-
-# Generates by-*.idx files for the CGI scripts
-# Copyright (c) 2005/08/03 Anthony Towns
-# GPL v2
-
-use DB_File;
-use MLDBM qw(DB_FILE Storable);
-use Fcntl qw/O_RDWR O_CREAT O_TRUNC/;
-use File::Copy;
-
-use Getopt::Long;
-use Pod::Usage;
-
-use warnings;
-use strict;
-
-use File::stat;
-use List::Util qw(min);
-
-=head1 NAME
-
-gen-indices - Generates index files for the cgi scripts
-
-=head1 SYNOPSIS
-
- gen-indices [options]
-
- Options:
- --index-path path to index location
- --quick update changed bugs
- --debug, -d debugging level (Default 0)
- --help, -h display this help
- --man, -m display manual
-
-=head1 OPTIONS
-
-=over
-
-=itme B<--quick>
-
-Only update changed bugs
-
-=item B<--debug, -d>
-
-Debug verbosity. (Default 0)
-
-=item B<--help, -h>
-
-Display brief useage information.
-
-=item B<--man, -m>
-
-Display this manual.
-
-=back
-
-=head1 EXAMPLES
-
-
-=cut
-
-# Use portable Storable images
-$MLDBM::DumpMeth=q(portable);
-
-
-my %options = (debug => 0,
- help => 0,
- man => 0,
- quick => 0,
- index_path => undef,
- );
-
-GetOptions(\%options,'quick!','index_path|index-path=s','debug|d+','help|h|?','man|m') or pod2usage(2);
-pod2usage(1) if $options{help};
-pod2usage(-verbose=>2) if $options{man};
-
-use Debbugs::Config qw(:config);
-use Debbugs::Common qw(getparsedaddrs getbugcomponent lockpid);
-use Debbugs::Status qw(readbug);
-
-chdir($config{spool_dir}) or die "chdir $config{spool_dir} failed: $!";
-
-my $verbose = $options{debug};
-my $indexdest = $options{index_path} || $config{spool_dir};
-
-my $initialdir = "db-h";
-my $suffix = "";
-
-if (defined $ARGV[0] and $ARGV[0] eq "archive") {
- $initialdir = "archive";
- $suffix = "-arc";
-}
-
-if (not lockpid($config{spool_dir}.'/lock/gen-indices')) {
- if ($options{quick}) {
- # If this is a quick run, just exit
- print STDERR "Another gen-indices is running; stopping\n" if $verbose;
- exit 0;
- }
- print STDERR "Another gen-indices is running; stopping\n";
- exit 1;
-}
-
-# NB: The reverse index is special; it's used to clean up during updates to bugs
-my @indexes = ('package', 'tag', 'severity','owner','submitter-email','status','reverse');
-my $indexes;
-my %slow_index = ();
-my %fast_index = ();
-if (not $options{quick}) {
- # We'll trade memory for speed here if we're not doing a quick rebuild
- for my $indexes (@indexes) {
- $fast_index{$indexes} = {};
- }
- $indexes = \%fast_index;
-}
-else {
- $indexes = \%slow_index;
-}
-my $time = undef;
-my $start_time = time;
-for my $i (@indexes) {
- $slow_index{$i} = {};
- if ($options{quick}) {
- if (-e "$indexdest/by-$i${suffix}.idx") {
- system('cp','-a',"$indexdest/by-$i${suffix}.idx","$indexdest/by-$i${suffix}.idx.new") == 0
- or die "Error creating the new index";
- my $stat = stat("$indexdest/by-$i${suffix}.idx") or die "Unable to stat $indexdest/by-$i${suffix}.idx";
- $time = defined $time ? min($time,$stat->mtime) : $stat->mtime;
- }
- tie %{$slow_index{$i}}, MLDBM => "$indexdest/by-$i$suffix.idx.new",
- O_RDWR|O_CREAT, 0666
- or die "$0: can't create by-$i$suffix-idx.new: $!";
- }
- else {
- tie %{$slow_index{$i}}, MLDBM => "$indexdest/by-$i$suffix.idx.new",
- O_RDWR|O_CREAT|O_TRUNC, 0666
- or die "$0: can't create by-$i$suffix-idx.new: $!";
-
- }
- $time = 0 if not defined $time;
-}
-
-sub addbugtoindex {
- my ($index, $bug, @values) = @_;
-
- if (exists $indexes->{reverse}{"$index $bug"}) {
- # We do this insanity to work around a "feature" in MLDBM
- for my $key (@{$indexes->{reverse}{"$index $bug"}}) {
- my $temp = $indexes->{$index}{$key};
- delete $temp->{$bug};
- $indexes->{$index}{$key} = $temp;
- $indexes->{$index}{"count $key"}--;
- }
- delete $indexes->{reverse}{"$index $bug"};
- }
- for my $key (@values) {
- $indexes->{$index}->{"count $key"}++;
- # We do this insanity to work around a "feature" in MLDBM
- my $temp = $indexes->{$index}->{$key};
- $temp->{$bug} = 1;
- $indexes->{$index}->{$key} = $temp;
- }
- $indexes->{reverse}{"$index $bug"} = [@values];
-}
-
-sub emailfromrfc822 {
- my $email = shift;
- $email =~ s/\s*\(.*\)\s*//;
- $email = $1 if ($email =~ m/<(.*)>/);
- return $email;
-}
-
-my $cnt = 0;
-
-my @dirs = ($initialdir);
-while (my $dir = shift @dirs) {
- printf "Doing dir %s ...\n", $dir if $verbose;
-
- opendir(DIR, "$dir/.") or die "opendir $dir: $!";
- my @subdirs = readdir(DIR);
- closedir(DIR);
-
- my @list = map { m/^(\d+)\.summary$/?($1):() } @subdirs;
- push @dirs, map { m/^(\d+)$/ && -d "$dir/$1"?("$dir/$1"):() } @subdirs;
-
- for my $bug (@list) {
- print "Up to $cnt bugs...\n" if (++$cnt % 100 == 0 && $verbose);
- my $stat = stat(getbugcomponent($bug,'summary',$initialdir));
- if (not defined $stat) {
- print STDERR "Unable to stat $bug $!\n";
- next;
- }
- next if $stat->mtime < $time;
- my $fdata = readbug($bug, $initialdir);
- addbugtoindex("package", $bug, split /[\s,]+/, $fdata->{"package"});
- addbugtoindex("tag", $bug, split /[\s,]+/, $fdata->{"keywords"});
- addbugtoindex('submitter-email', $bug,
- map {lc($_->address)} getparsedaddrs($fdata->{originator}));
- addbugtoindex("severity", $bug, $fdata->{"severity"});
- addbugtoindex("owner", $bug,
- map {lc($_->address)} getparsedaddrs($fdata->{"owner"}));
- }
-}
-
-if (not $options{quick}) {
- # put the fast index into the slow index
- for my $key1 (keys %fast_index) {
- for my $key2 (keys %{$fast_index{$key1}}) {
- $slow_index{$key1}{$key2} = $fast_index{$key1}{$key2};
- }
- print "Dealt with index $key1\n" if $verbose;
- }
-}
-
-
-for my $i (@indexes) {
- untie %{$slow_index{$i}};
- move("$indexdest/by-$i$suffix.idx.new", "$indexdest/by-$i$suffix.idx");
- # We do this, because old versions of touch don't support -d '@epoch'
- system('touch','-d',"1/1/1970 UTC + ${start_time}secs","$indexdest/by-$i$suffix.idx");
-}
-
-unlink($config{spool_dir}.'/lock/gen-indices')
--- /dev/null
+#!/usr/bin/perl
+# $Id: html-control.in,v 1.12 2004/10/26 14:00:05 cjwatson Exp $
+
+use POSIX qw(strftime tzset ENOENT);
+$ENV{"TZ"} = 'UTC';
+tzset();
+
+$config_path = '/etc/debbugs';
+$lib_path = '/usr/lib/debbugs';
+
+require("$config_path/config");
+require("$lib_path/errorlib");
+$ENV{'PATH'} = $lib_path.':'.$ENV{'PATH'};
+
+chdir("$gSpoolDir") || die "chdir spool: $!\n";
+#push(@INC,"$lib_path");
+
+&filelock("html.fcntl-lock");
+
+unlink("html-data.gz") || $!==&ENOENT or die "remove html-data.gz: $!";
+
+sub nonawful ($) {
+ rename("stamp.html.run","stamp.html") or warn "warning: put back stamp.html: $!";
+ die $_[0];
+}
+
+if (open(US,'updateseqs') && -f 'stamp.html') {
+ chop($lastmain=<US>);
+ chop($lastsub=<US>);
+ close(US);
+
+ $lastsub++;
+ $args= "-diff -stampfile=stamp.html.run";
+ rename("stamp.html","stamp.html.run") or die "rename stamp.html: $!";
+} else {
+ $lastsub=0;
+ $lastmain = strftime "%Y%m%d%H%M%S", localtime;
+ $args= '-full';
+ unlink('stamp.html') || $!==&ENOENT or die "excise stale stamp.html: $!";
+}
+
+open(X,">stamp.html.new") or die "stamp.html.new: $!";
+close(X) or die "close stamp.html.new: $!";
+
+open(US,'>updateseqs.new') || die "create updateseqs.new: $!";
+print(US "$lastmain\n$lastsub\n") || die "write updateseqs.new: $!";
+close(US) || die "close updateseqs.new: $!";
+rename('updateseqs.new','updateseqs') or nonawful("install updateseqs: $!");
+
+sub runshell ($&) {
+ my ($cmd,$errhref) = @_;
+ print "xx $cmd\n";
+ system $cmd;
+ !$? && !length($stderr) or &$errhref("$cmd failed - gave $? / $stderr");
+}
+
+$sequences="$lastmain $lastsub";
+$seqmid= $sequences; $seqmid =~ y/ /-/;
+open(MM,">html-data.mail") or nonawful("open html-data.mail: $!");
+if ( length( $gListDomain ) > 0 && length( $gMirrorList ) > 0 ) {
+print(MM <<END
+From: $gMaintainerEmail ($gProject $gBug Tracking System)
+To: $gMirrorList\@$gListDomain
+Subject: $gProject $gBugs autoupdate 259012
+Message-ID: <handle.htmlup.$seqmid\@$gEmailDomain>
+X-$gProject-PR: update $sequences
+
+END
+ ) or nonawful("write html-data.mail header: $!");
+} else {
+print(MM <<END
+From: $gMaintainerEmail ($gProject $gBug Tracking System)
+To: $gMaintainerEmail
+Subject: $gProject $gBugs autoupdate 259012
+Message-ID: <handle.htmlup.$seqmid\@$gEmailDomain>
+X-$gProject-PR: update $sequences
+
+END
+ ) or nonawful("write html-data.mail header: $!");
+}
+close(MM) or nonawful("close html-data.mail: $!");
+
+runshell("$lib_path/db2html $args 2>&1 >html-data $gWebDir/db",
+ sub { &nonawful; });
+runshell("$lib_path/html-install $gWebDir/db <html-data 2>&1",sub { &quit; });
+#runshell("gzip -9 html-data 2>&1",sub { &quit; });
+#runshell("btoa 2>&1 <html-data.gz >>html-data.mail",sub { &quit; });
+#runshell('2>&1 '.join(' ',('/usr/lib/sendmail','-f'."$gMaintainerEmail")).' -oem -oi -t <html-data.mail',
+# sub { &quit; });
+
+rename("stamp.html.new","stamp.html") or die "install new stamp.html: $!";
+
+unlink("html-data") or warn "remove html-data: $!";
+#unlink("html-data.gz") or warn "remove html-data.gz: $!";
+#unlink("html-data.mail") or warn "remove html-data.mail: $!";
+unlink("stamp.html.run") || $!==&ENOENT or warn "remove stamp.html.run: $!";
+
+print "sequences $lastmain $lastsub\n";
+
+&unfilelock();
+exit(0);
+++ /dev/null
-#!/usr/bin/perl
-# $Id: html-control.in,v 1.12 2004/10/26 14:00:05 cjwatson Exp $
-
-use POSIX qw(strftime tzset ENOENT);
-$ENV{"TZ"} = 'UTC';
-tzset();
-
-$config_path = '/etc/debbugs';
-$lib_path = '/usr/lib/debbugs';
-
-require("$config_path/config");
-require("$lib_path/errorlib");
-$ENV{'PATH'} = $lib_path.':'.$ENV{'PATH'};
-
-chdir("$gSpoolDir") || die "chdir spool: $!\n";
-#push(@INC,"$lib_path");
-
-&filelock("html.fcntl-lock");
-
-unlink("html-data.gz") || $!==&ENOENT or &quit("remove html-data.gz: $!");
-
-sub nonawful ($) {
- rename("stamp.html.run","stamp.html") or warn "warning: put back stamp.html: $!";
- &quit($_[0]);
-}
-
-if (open(US,'updateseqs') && -f 'stamp.html') {
- chop($lastmain=<US>);
- chop($lastsub=<US>);
- close(US);
-
- $lastsub++;
- $args= "-diff -stampfile=stamp.html.run";
- rename("stamp.html","stamp.html.run") or &quit("rename stamp.html: $!");
-} else {
- $lastsub=0;
- $lastmain = strftime "%Y%m%d%H%M%S", localtime;
- $args= '-full';
- unlink('stamp.html') || $!==&ENOENT or &quit("excise stale stamp.html: $!");
-}
-
-open(X,">stamp.html.new") or &quit("stamp.html.new: $!");
-close(X) or &quit("close stamp.html.new: $!");
-
-open(US,'>updateseqs.new') || &quit("create updateseqs.new: $!");
-print(US "$lastmain\n$lastsub\n") || &quit("write updateseqs.new: $!");
-close(US) || &quit("close updateseqs.new: $!");
-rename('updateseqs.new','updateseqs') or nonawful("install updateseqs: $!");
-
-sub runshell ($&) {
- my ($cmd,$errhref) = @_;
- print "xx $cmd\n";
- system $cmd;
- !$? && !length($stderr) or &$errhref("$cmd failed - gave $? / $stderr");
-}
-
-$sequences="$lastmain $lastsub";
-$seqmid= $sequences; $seqmid =~ y/ /-/;
-open(MM,">html-data.mail") or nonawful("open html-data.mail: $!");
-if ( length( $gListDomain ) > 0 && length( $gMirrorList ) > 0 ) {
-print(MM <<END
-From: $gMaintainerEmail ($gProject $gBug Tracking System)
-To: $gMirrorList\@$gListDomain
-Subject: $gProject $gBugs autoupdate 259012
-Message-ID: <handle.htmlup.$seqmid\@$gEmailDomain>
-X-$gProject-PR: update $sequences
-
-END
- ) or nonawful("write html-data.mail header: $!");
-} else {
-print(MM <<END
-From: $gMaintainerEmail ($gProject $gBug Tracking System)
-To: $gMaintainerEmail
-Subject: $gProject $gBugs autoupdate 259012
-Message-ID: <handle.htmlup.$seqmid\@$gEmailDomain>
-X-$gProject-PR: update $sequences
-
-END
- ) or nonawful("write html-data.mail header: $!");
-}
-close(MM) or nonawful("close html-data.mail: $!");
-
-runshell("$lib_path/db2html $args 2>&1 >html-data $gWebDir/db",
- sub { &nonawful; });
-runshell("$lib_path/html-install $gWebDir/db <html-data 2>&1",sub { &quit; });
-#runshell("gzip -9 html-data 2>&1",sub { &quit; });
-#runshell("btoa 2>&1 <html-data.gz >>html-data.mail",sub { &quit; });
-#runshell('2>&1 '.join(' ',('/usr/lib/sendmail','-f'."$gMaintainerEmail")).' -oem -oi -t <html-data.mail',
-# sub { &quit; });
-
-rename("stamp.html.new","stamp.html") or &quit("install new stamp.html: $!");
-
-unlink("html-data") or warn "remove html-data: $!";
-#unlink("html-data.gz") or warn "remove html-data.gz: $!";
-#unlink("html-data.mail") or warn "remove html-data.mail: $!";
-unlink("stamp.html.run") || $!==&ENOENT or warn "remove stamp.html.run: $!";
-
-print "sequences $lastmain $lastsub\n";
-
-&unfilelock();
-exit(0);
--- /dev/null
+#!/usr/bin/perl
+# $Id: html-install.in,v 1.4 2002/11/17 22:45:16 cjwatson Exp $
+# Takes 1 argument - directory tree to install into
+# Tree _must_ be synch'd with one used by db2html to generate file
+
+use POSIX;
+$config_path = '/etc/debbugs';
+
+require("$config_path/config");
+$ENV{'PATH'} = $lib_path.':'.$ENV{'PATH'};
+
+$dirtree= shift(@ARGV);
+defined($dirtree) or die 'usage';
+chdir $dirtree or die $!;
+
+$filenamere= '[0-9a-z]{2}/[0-9a-z][-+_:,.0-9a-zA-Z]*';
+
+opendir(D,".") or die " opendir: $!";
+while ($dir=readdir(D)) {
+ next if $dir =~ m/^\.\.?$/;
+ if (-f $dir) {
+ $remove{$dir}= 1;
+ } else {
+ opendir(E,"$dir") or die " opendir $dir: $!";
+ while ($_=readdir(E)) {
+ next if $_ =~ m/^\.\.?$/;
+ $remove{"$dir/$_"}= 1;
+ }
+ closedir(E) or die " closedir $dir: $!";
+ $rmdir{$dir}= 1;
+ }
+}
+closedir(D) or die " closedir: $!";
+
+while(<>) {
+ chomp;
+ if (m/^end$/) {
+ print "end, removing\n";
+ for $k (keys %remove) { unlink($k) || $!==&ENOENT or die "$k: $!"; }
+ for $k (keys %rmdir) { rmdir($k) || $!==&ENOTEMPTY || $!==EEXIST or die "$k: $!"; }
+ exit 0;
+ } elsif (s/^progress //) {
+ y/-+:._!#=,0-9a-zA-Z //cd;
+ print " progress $_\n";
+ } elsif (m/^preserve ($filenamere)$/o) {
+ delete $remove{$1};
+ delete $remove{"$1.ref"};
+ print " preserve $1\n";
+ } elsif (m/^(file|diff) (\d+) (ref|def|non) ($filenamere)$/o) {
+ $filediff= $1; $linestodo= $2; $ii= $3; $file= $4;
+ print " $filediff $ii $file\n";
+ delete $remove{$file};
+ delete $remove{"$file.ref"} if $ii eq 'ref';
+ $file =~ m,^(..)/, or die $file;
+ mkdir($1,0777) || $!==EEXIST or die $!;
+ $tranfile= $file;
+ $tranfile.= '.ref' if $ii eq 'ref';
+ open(DT,"> recv.tmp") or die $!;
+ if ($filediff eq 'diff') { print DT "r $tranfile\n" or die $!; }
+ $indata= 0;
+ while ($linestodo--) {
+ $z=<STDIN>;
+ if ($filediff eq 'diff') {
+ if ($indata) { $indata=0 if $incmd && m/^\.$/; }
+ elsif ($z =~ m/^[0-9,]+[ac]/) { $indata= 1; }
+ elsif ($z !~ m/^[0-9,]+[ds]/) { die "SECURITY $file >$z<"; }
+ }
+ print DT $z or die $!;
+ }
+ if ($filediff eq 'diff') { print DT "w new.tmp\nq\n" or die $!; }
+ close(DT) or die $!;
+ ($z=<STDIN>) eq "that$filediff $file\n" or die die "not confirmed >$z<";
+ if ($filediff eq 'diff') {
+ $q= `ed -s <recv.tmp 2>&1`;
+ length($q) || $? and die "ed $q $?";
+ rename("new.tmp","$tranfile") or die "$tranfile $!";
+ unlink("recv.tmp") or die $!;
+ } else {
+ rename("recv.tmp","$tranfile") or die "$tranfile $!";
+ }
+ if ($ii eq 'ref') {
+ open(I,"$tranfile") or die $!;
+ open(O,"> ref.tmp") or die $!;
+ while (<I>) {
+ if (m/^\<\!\-\-ii (\d+)\-\-\>$/) {
+ defined($iival{$1}) or die "$tranfile $1";
+ print O $iival{$1} or die $!;
+ } else {
+ print O or die $!;
+ }
+ }
+ close(I) or die $!;
+ close(O) or die $!;
+ rename("ref.tmp","$file") or die $!;
+ } elsif ($ii eq 'def') {
+ open(I,"$file") or die $!;
+ undef $cdef; $ctext= '';
+ while (<I>) {
+ if (s/^\<\!\-\-iid (\d+)\-\-\>//) {
+ defined($cdef) and die $file;
+ $cdef= $1;
+ $ctext= $_;
+ } elsif (s/\<\!\-\-\/iid\-\-\>\n$//) {
+ defined($cdef) or die $file;
+ $iival{$cdef}= $ctext.$_."\n";
+ $ctext=''; undef $cdef;
+ } else {
+ $ctext.= $_ if defined($cdef);
+ }
+ }
+ }
+ } elsif (m/^noremoves$/) {
+ print "noremoves\n";
+ exit 0;
+ } else {
+ die " huh ? $_";
+ }
+}
+
+die "eof $!";
+++ /dev/null
-#!/usr/bin/perl
-# $Id: html-install.in,v 1.4 2002/11/17 22:45:16 cjwatson Exp $
-# Takes 1 argument - directory tree to install into
-# Tree _must_ be synch'd with one used by db2html to generate file
-
-use POSIX;
-$config_path = '/etc/debbugs';
-
-require("$config_path/config");
-$ENV{'PATH'} = $lib_path.':'.$ENV{'PATH'};
-
-$dirtree= shift(@ARGV);
-defined($dirtree) or die 'usage';
-chdir $dirtree or die $!;
-
-$filenamere= '[0-9a-z]{2}/[0-9a-z][-+_:,.0-9a-zA-Z]*';
-
-opendir(D,".") or die " opendir: $!";
-while ($dir=readdir(D)) {
- next if $dir =~ m/^\.\.?$/;
- if (-f $dir) {
- $remove{$dir}= 1;
- } else {
- opendir(E,"$dir") or die " opendir $dir: $!";
- while ($_=readdir(E)) {
- next if $_ =~ m/^\.\.?$/;
- $remove{"$dir/$_"}= 1;
- }
- closedir(E) or die " closedir $dir: $!";
- $rmdir{$dir}= 1;
- }
-}
-closedir(D) or die " closedir: $!";
-
-while(<>) {
- chomp;
- if (m/^end$/) {
- print "end, removing\n";
- for $k (keys %remove) { unlink($k) || $!==&ENOENT or die "$k: $!"; }
- for $k (keys %rmdir) { rmdir($k) || $!==&ENOTEMPTY || $!==EEXIST or die "$k: $!"; }
- exit 0;
- } elsif (s/^progress //) {
- y/-+:._!#=,0-9a-zA-Z //cd;
- print " progress $_\n";
- } elsif (m/^preserve ($filenamere)$/o) {
- delete $remove{$1};
- delete $remove{"$1.ref"};
- print " preserve $1\n";
- } elsif (m/^(file|diff) (\d+) (ref|def|non) ($filenamere)$/o) {
- $filediff= $1; $linestodo= $2; $ii= $3; $file= $4;
- print " $filediff $ii $file\n";
- delete $remove{$file};
- delete $remove{"$file.ref"} if $ii eq 'ref';
- $file =~ m,^(..)/, or die $file;
- mkdir($1,0777) || $!==EEXIST or die $!;
- $tranfile= $file;
- $tranfile.= '.ref' if $ii eq 'ref';
- open(DT,"> recv.tmp") or die $!;
- if ($filediff eq 'diff') { print DT "r $tranfile\n" or die $!; }
- $indata= 0;
- while ($linestodo--) {
- $z=<STDIN>;
- if ($filediff eq 'diff') {
- if ($indata) { $indata=0 if $incmd && m/^\.$/; }
- elsif ($z =~ m/^[0-9,]+[ac]/) { $indata= 1; }
- elsif ($z !~ m/^[0-9,]+[ds]/) { die "SECURITY $file >$z<"; }
- }
- print DT $z or die $!;
- }
- if ($filediff eq 'diff') { print DT "w new.tmp\nq\n" or die $!; }
- close(DT) or die $!;
- ($z=<STDIN>) eq "that$filediff $file\n" or die die "not confirmed >$z<";
- if ($filediff eq 'diff') {
- $q= `ed -s <recv.tmp 2>&1`;
- length($q) || $? and die "ed $q $?";
- rename("new.tmp","$tranfile") or die "$tranfile $!";
- unlink("recv.tmp") or die $!;
- } else {
- rename("recv.tmp","$tranfile") or die "$tranfile $!";
- }
- if ($ii eq 'ref') {
- open(I,"$tranfile") or die $!;
- open(O,"> ref.tmp") or die $!;
- while (<I>) {
- if (m/^\<\!\-\-ii (\d+)\-\-\>$/) {
- defined($iival{$1}) or die "$tranfile $1";
- print O $iival{$1} or die $!;
- } else {
- print O or die $!;
- }
- }
- close(I) or die $!;
- close(O) or die $!;
- rename("ref.tmp","$file") or die $!;
- } elsif ($ii eq 'def') {
- open(I,"$file") or die $!;
- undef $cdef; $ctext= '';
- while (<I>) {
- if (s/^\<\!\-\-iid (\d+)\-\-\>//) {
- defined($cdef) and die $file;
- $cdef= $1;
- $ctext= $_;
- } elsif (s/\<\!\-\-\/iid\-\-\>\n$//) {
- defined($cdef) or die $file;
- $iival{$cdef}= $ctext.$_."\n";
- $ctext=''; undef $cdef;
- } else {
- $ctext.= $_ if defined($cdef);
- }
- }
- }
- } elsif (m/^noremoves$/) {
- print "noremoves\n";
- exit 0;
- } else {
- die " huh ? $_";
- }
-}
-
-die "eof $!";
--- /dev/null
+#!/usr/bin/perl
+# $Id: mailsummary.in,v 1.11 2003/04/28 23:51:15 cjwatson Exp $
+
+$config_path = '/etc/debbugs';
+$lib_path = '/usr/lib/debbugs';
+
+require("$config_path/config");
+require("$lib_path/errorlib");
+$ENV{'PATH'} = $lib_path.':'.$ENV{'PATH'};
+
+chdir("$gSpoolDir") || die "chdir spool: $!\n";
+
+#open(DEBUG,">&4");
+
+if ($ARGV[0] eq 'undone') {
+ $vdef= "(no outstanding $gBug reports on file, or problem running script)\n";
+ $subject= "Unanswered problem reports by date";
+ $intro=
+"The following problem reports have not yet been marked as `taken up\' by a
+message to done\@$gEmailDomain or or `forwarded\' by a
+message to forwarded\@$gEmailDomain."
+ ;
+} elsif ($ARGV[0] eq 'bymaint') {
+ $vdef= "(no outstanding $gBug reports on file, or problem running script)\n";
+ $subject= "Unanswered problem reports by maintainer and package";
+ $intro=
+"The following problem reports have not yet been marked as `taken up\' by a
+message to done\@$gEmailDomain or or `forwarded\' by a
+message to forwarded\@$gEmailDomain.
+The maintainer listed against each package is derived from the Maintainer
+field of the package found in the development tree; there is an override file
+that can be amended to get the right results if you have taken over a package
+and do not expect to issue a new version soon.
+
+Variant versions of the Maintainer field for the same actual package
+maintainer will be listed separately.
+
+Maintainers with few outstanding $gBugs appear first, to avoid those with few
+$gBugs being lost deep in the message.
+"
+ ;
+} elsif ($ARGV[0] eq 'veryold') {
+ $vdef= '';
+ $subject= "Overdue problem reports by age";
+ $intro=
+"The following problem reports are very old but have not yet been marked
+as `taken up\' by a message to done\@$gEmailDomain as forwarded
+to a developer by CCing a message to forwarded\@$gEmailDomain.
+Please help ensure that these $gBugs are dealt with quickly, even if you
+are not the package maintainer in question. (NB a full list of outstanding
+$gBug reports is posted periodically - this is a partial list only!)
+"
+} else {
+ die "urgk, wrong argument @ARGV";
+}
+
+$v=`$lib_path/summary $ARGV[0]`; $? && die "undone failed $?: $!\n";
+
+$v= $vdef if $v eq '';
+exit 0 if $v eq '';
+
+open(D, '| '.join(' ',('/usr/lib/sendmail','-f'.$gMaintainerEmail)).' -odq -oem -oi -t') ||
+ die "start sendmail: $!";
+
+print D <<END || die "complete sendmail";
+From: $gMaintainerEmail ($gProject $gBug Tracking System)
+To: $gSummaryList\@$gListDomain
+Subject: $subject
+
+$intro
+$v
+Every Tuesday, the listing by package maintainer is posted.
+Every Friday, the listing by age of the report is posted.
+
+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>
+END
+
+close(D);
+$? && die "sendmail failed $?: $!\n";
+
+print length($v)," bytes of summary posted.\n";
+++ /dev/null
-#!/usr/bin/perl
-# $Id: mailsummary.in,v 1.11 2003/04/28 23:51:15 cjwatson Exp $
-
-$config_path = '/etc/debbugs';
-$lib_path = '/usr/lib/debbugs';
-
-require("$config_path/config");
-require("$lib_path/errorlib");
-$ENV{'PATH'} = $lib_path.':'.$ENV{'PATH'};
-
-chdir("$gSpoolDir") || die "chdir spool: $!\n";
-
-#open(DEBUG,">&4");
-
-if ($ARGV[0] eq 'undone') {
- $vdef= "(no outstanding $gBug reports on file, or problem running script)\n";
- $subject= "Unanswered problem reports by date";
- $intro=
-"The following problem reports have not yet been marked as `taken up\' by a
-message to done\@$gEmailDomain or or `forwarded\' by a
-message to forwarded\@$gEmailDomain."
- ;
-} elsif ($ARGV[0] eq 'bymaint') {
- $vdef= "(no outstanding $gBug reports on file, or problem running script)\n";
- $subject= "Unanswered problem reports by maintainer and package";
- $intro=
-"The following problem reports have not yet been marked as `taken up\' by a
-message to done\@$gEmailDomain or or `forwarded\' by a
-message to forwarded\@$gEmailDomain.
-The maintainer listed against each package is derived from the Maintainer
-field of the package found in the development tree; there is an override file
-that can be amended to get the right results if you have taken over a package
-and do not expect to issue a new version soon.
-
-Variant versions of the Maintainer field for the same actual package
-maintainer will be listed separately.
-
-Maintainers with few outstanding $gBugs appear first, to avoid those with few
-$gBugs being lost deep in the message.
-"
- ;
-} elsif ($ARGV[0] eq 'veryold') {
- $vdef= '';
- $subject= "Overdue problem reports by age";
- $intro=
-"The following problem reports are very old but have not yet been marked
-as `taken up\' by a message to done\@$gEmailDomain as forwarded
-to a developer by CCing a message to forwarded\@$gEmailDomain.
-Please help ensure that these $gBugs are dealt with quickly, even if you
-are not the package maintainer in question. (NB a full list of outstanding
-$gBug reports is posted periodically - this is a partial list only!)
-"
-} else {
- die "urgk, wrong argument @ARGV";
-}
-
-$v=`$lib_path/summary $ARGV[0]`; $? && die "undone failed $?: $!\n";
-
-$v= $vdef if $v eq '';
-exit 0 if $v eq '';
-
-open(D, '| '.join(' ',('/usr/lib/sendmail','-f'.$gMaintainerEmail)).' -odq -oem -oi -t') ||
- die "start sendmail: $!";
-
-print D <<END || die "complete sendmail";
-From: $gMaintainerEmail ($gProject $gBug Tracking System)
-To: $gSummaryList\@$gListDomain
-Subject: $subject
-
-$intro
-$v
-Every Tuesday, the listing by package maintainer is posted.
-Every Friday, the listing by age of the report is posted.
-
-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>
-END
-
-close(D);
-$? && die "sendmail failed $?: $!\n";
-
-print length($v)," bytes of summary posted.\n";
--- /dev/null
+#!/usr/bin/perl
+# $Id: process.in,v 1.109 2006/02/09 22:02:04 don Exp $
+#
+# Usage: process nn
+# Temps: incoming/Pnn
+
+use warnings;
+use strict;
+
+use POSIX qw(strftime);
+
+use IO::File;
+
+use MIME::Parser;
+use Debbugs::MIME qw(decode_rfc1522 create_mime_message getmailbody);
+use Debbugs::Mail qw(send_mail_message encode_headers);
+use Debbugs::Packages qw(getpkgsrc);
+use Debbugs::User qw(read_usertags write_usertags);
+use Debbugs::Common qw(:lock get_hashname);
+use Debbugs::Status qw(writebug isstrongseverity lockreadbugmerge lockreadbug);
+
+use Debbugs::CGI qw(html_escape bug_url);
+
+use Debbugs::Log qw(:misc);
+
+use Debbugs::Text qw(:templates);
+
+use Debbugs::Status qw(:versions);
+use Debbugs::Config qw(:globals :config);
+
+chdir( "$gSpoolDir" ) || die "chdir spool: $!\n";
+
+#open(DEBUG,"> /tmp/debbugs.debug");
+umask(002);
+open DEBUG, ">/dev/null";
+
+my $intdate = time or die "failed to get time: $!";
+
+$_=shift;
+m/^([BMQFDUL])(\d*)\.\d+$/ or die "bad argument: $_";
+my $codeletter= $1;
+my $tryref= length($2) ? $2 : -1;
+my $nn= $_;
+
+if (!rename("incoming/G$nn","incoming/P$nn"))
+{
+ $_=$!.''; m/no such file or directory/i && exit 0;
+ die "renaming to lock: $!";
+}
+
+my $baddress= 'submit' if $codeletter eq 'B';
+$baddress= 'maintonly' if $codeletter eq 'M';
+$baddress= 'quiet' if $codeletter eq 'Q';
+$baddress= 'forwarded' if $codeletter eq 'F';
+$baddress= 'done' if $codeletter eq 'D';
+$baddress= 'submitter' if $codeletter eq 'U';
+bug_list_forward($nn) if $codeletter eq 'L';
+$baddress || die "bad codeletter $codeletter";
+my $baddressroot= $baddress;
+$baddress= "$tryref-$baddress" if $tryref>=0;
+
+open(M,"incoming/P$nn");
+my @log=<M>;
+close(M);
+
+my @msg = @log;
+chomp @msg;
+
+print DEBUG "###\n",join("##\n",@msg),"\n###\n";
+
+my $tdate = strftime "%a, %d %h %Y %T +0000", gmtime;
+my $fwd= <<END;
+Received: via spool by $baddress\@$gEmailDomain id=$nn
+ (code $codeletter ref $tryref); $tdate
+END
+
+# header and decoded body respectively
+my (@headerlines, @bodylines);
+
+# whether maintainer addresses have been checked
+our $maintainerschecked = 0;
+#maintainer address for this message
+our @maintaddrs;
+# other src addresses
+our @addsrcaddrs;
+our @resentccs;
+our @bccs;
+
+my $resentccexplain='';
+
+# whether there's a new reference with this email
+our $newref = 0;
+
+our $brokenness = '';
+
+my $parser = new MIME::Parser;
+mkdir "$gSpoolDir/mime.tmp", 0777;
+$parser->output_under("$gSpoolDir/mime.tmp");
+my $entity = eval { $parser->parse_data(join('',@log)) };
+
+my $i;
+if ($entity and $entity->head->tags) {
+ @headerlines = @{$entity->head->header};
+ chomp @headerlines;
+
+ my $entity_body = getmailbody($entity);
+ @bodylines = map {s/\r?\n$//; $_;}
+ $entity_body ? $entity_body->as_lines() : ();
+
+ # set $i to beginning of encoded body data, so we can dump it out
+ # verbatim later
+ $i = 0;
+ ++$i while $msg[$i] =~ /./;
+} else {
+ # Legacy pre-MIME code, kept around in case MIME::Parser fails.
+ for ($i = 0; $i <= $#msg; $i++) {
+ $_ = $msg[$i];
+ last unless length($_);
+ while ($msg[$i+1] =~ m/^\s/) {
+ $i++;
+ $_ .= "\n".$msg[$i];
+ }
+ push @headerlines, $_;
+ }
+
+ @bodylines = @msg[$i..$#msg];
+}
+
+my %header;
+
+for my $hdr (@headerlines) {
+ $hdr = decode_rfc1522($hdr);
+ $_ = $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;
+ $fwd .= $hdr."\n" if $ins;
+ # print DEBUG ">$_<\n";
+ if (s/^(\S+):\s*//) {
+ my $v = lc $1;
+ print DEBUG ">$v=$_<\n";
+ $header{$v} = $_;
+ } else {
+ print DEBUG "!>$_<\n";
+ }
+}
+$header{'message-id'} = '' if not defined $header{'message-id'};
+
+# remove blank lines
+shift @bodylines while @bodylines and $bodylines[0] !~ /\S/;
+
+# Strip off RFC2440-style PGP clearsigning.
+if (@bodylines and $bodylines[0] =~ /^-----BEGIN PGP SIGNED/) {
+ shift @bodylines while @bodylines and length $bodylines[0];
+ shift @bodylines while @bodylines and $bodylines[0] !~ /\S/;
+ for my $findsig (0 .. $#bodylines) {
+ if ($bodylines[$findsig] =~ /^-----BEGIN PGP SIGNATURE/) {
+ $#bodylines = $findsig - 1;
+ last;
+ }
+ }
+ map { s/^- // } @bodylines;
+}
+
+#psuedoheaders
+my %pheader;
+# extract pseudo-headers
+for my $phline (@bodylines)
+{
+ last if $phline !~ m/^([\w-]+):\s*(\S.*)/;
+ my ($fn, $fv) = ($1, $2);
+ $fv =~ s/\s*$//;
+ print DEBUG ">$fn|$fv|\n";
+ $fn = lc $fn;
+ # Don't lc owner or forwarded
+ $fv = lc $fv unless $fn =~ /^(?:owner|forwarded|usertags|version|source-version)$/;
+ $pheader{$fn} = $fv;
+ print DEBUG ">$fn~$fv<\n";
+}
+
+# Allow pseudo headers to set x-debbugs- stuff [#179340]
+for my $key (grep /X-Debbugs-.*/i, keys %pheader) {
+ $header{$key} = $pheader{$key} if not exists $header{$key};
+}
+
+$fwd .= join("\n",@msg[$i..$#msg]);
+
+print DEBUG "***\n$fwd\n***\n";
+
+if (defined $header{'resent-from'} && !defined $header{'from'}) {
+ $header{'from'} = $header{'resent-from'};
+}
+defined($header{'from'}) || die "no From header";
+
+my $replyto = $header{'reply-to'};
+$replyto = '' unless defined $replyto;
+$replyto =~ s/^ +//;
+$replyto =~ s/ +$//;
+unless (length $replyto) {
+ $replyto = $header{'from'};
+}
+
+my $subject = '(no subject)';
+if (!defined($header{'subject'}))
+{
+ $brokenness.= fill_template('mail/process_broken_subject');
+
+} else {
+ $subject= $header{'subject'};
+}
+
+my $ref=-1;
+$subject =~ s/^Re:\s*//i; $_= $subject."\n";
+if ($tryref < 0 && m/^Bug ?\#(\d+)\D/i) {
+ $tryref= $1+0;
+}
+my $data;
+if ($tryref >= 0)
+{
+ my $bfound;
+ ($bfound, $data)= &lockreadbugmerge($tryref);
+ if ($bfound) {
+ $ref= $tryref;
+ } else {
+ &htmllog("Reply","sent", $replyto,"Unknown problem report number <code>$tryref</code>.");
+ &sendmessage(create_mime_message(
+ [From => "$gMaintainerEmail ($gProject $gBug Tracking System)",
+ To => $replyto,
+ Subject => "Unknown problem report $gBug#$tryref ($subject)",
+ 'Message-ID' => "<handler.x.$nn.unknown\@$gEmailDomain>",
+ 'In-Reply-To' => $header{'message-id'},
+ References => join(' ',grep {defined $_} $header{'message-id'},$data->{msgid}),
+ Precedence => 'bulk',
+ "X-$gProject-PR-Message" => 'error',
+ ],message_body_template('process_unknown_bug_number',
+ {subject => $subject,
+ date => $header{date},
+ baddress => $baddress,
+ tryref => $tryref,
+ messageid => $header{'message-id'},
+ },
+ )),'');
+ &appendlog;
+ &finish;
+ }
+} else {
+ &filelock('lock/-1');
+}
+
+# Attempt to determine which source package this is
+my $source_pr_header = '';
+my $source_package = '';
+if (defined $pheader{source}) {
+ $source_package = $pheader{source};
+}
+elsif (defined $data->{package} or defined $pheader{package}) {
+ my $pkg_src = getpkgsrc();
+ $source_package = $pkg_src->{defined $data->{package}?$data->{package}:$pheader{package}};
+}
+$source_pr_header = "X-$gProject-PR-Source: $source_package\n"
+ if defined $source_package and length $source_package;
+
+# Done and Forwarded Bugs
+if ($codeletter eq 'D' || $codeletter eq 'F')
+{
+ if ($replyto =~ m/$gBounceFroms/o ||
+ $header{'from'} =~ m/$gBounceFroms/o)
+ {
+ print STDERR "bounce detected ! Mwaap! Mwaap!";
+ exit 1;
+ }
+ my $markedby= $header{'from'} eq $replyto ? $replyto :
+ "$header{'from'} (reply to $replyto)";
+ my @generalcc;
+ my $receivedat;
+ my $markaswhat;
+ my $set_forwarded;
+ my $generalcc;
+ my $set_done;
+ if ($codeletter eq 'F') { # Forwarded
+ (&appendlog,&finish) if defined $data->{forwarded} and length($data->{forwarded});
+ $receivedat= "forwarded\@$gEmailDomain";
+ $markaswhat= 'forwarded';
+ $set_forwarded= $header{'to'};
+ # Dissallow forwarded being set to this bug tracking system
+ if (defined $set_forwarded and $set_forwarded =~ /\Q$gEmailDomain\E/) {
+ undef $set_forwarded;
+ }
+ if ( length( $gListDomain ) > 0 && length( $gForwardList ) > 0 ) {
+ push @generalcc, "$gForwardList\@$gListDomain";
+ $generalcc= "$gForwardList\@$gListDomain";
+ } else {
+ $generalcc='';
+ }
+ } else { # Done
+ if (defined $data->{done} and length($data->{done}) and
+ not defined $pheader{'source-version'} and
+ not defined $pheader{'version'}) {
+ &appendlog;
+ &finish;
+ }
+ $receivedat= "done\@$gEmailDomain";
+ $markaswhat= 'done';
+ $set_done= $header{'from'};
+ if ( length( $gListDomain ) > 0 && length( $gDoneList ) > 0 ) {
+ $generalcc= "$gDoneList\@$gListDomain";
+ push @generalcc, "$gDoneList\@$gListDomain";
+ } else {
+ $generalcc='';
+ }
+ }
+ if (defined $gStrongList and isstrongseverity($data->{severity})) {
+ $generalcc = join ', ', $generalcc, "$gStrongList\@$gListDomain";
+ push @generalcc,"$gStrongList\@$gListDomain";
+ }
+ if ($ref<0) {
+ &htmllog("Warning","sent",$replyto,"Message ignored.");
+ &sendmessage(create_mime_message(
+ [From => "$gMaintainerEmail ($gProject $gBug Tracking System)",
+ To => $replyto,
+ Subject => "Message with no $gBug number ignored by $receivedat ($subject)",
+ 'Message-ID' => "<handler.x.$nn.warnignore\@$gEmailDomain>",
+ 'In-Reply-To' => $header{'message-id'},
+ References => join(' ',grep {defined $_} $header{'message-id'},$data->{msgid}),
+ Precedence => 'bulk',
+ "X-$gProject-PR-Message" => 'error',
+ ],message_body_template('mail/process_no_bug_number',
+ {subject => $subject,
+ date => $header{date},
+ markaswhat => $markaswhat,
+ receivedat => $receivedat,
+ messageid => $header{'message-id'},
+ },
+ )),'');
+ &appendlog;
+ &finish;
+ }
+
+ &checkmaintainers;
+
+ my @noticecc = grep($_ ne $replyto,@maintaddrs);
+ my $noticeccval.= join(', ', grep($_ ne $replyto,@maintaddrs));
+ $noticeccval =~ s/\s+\n\s+/ /g;
+ $noticeccval =~ s/^\s+/ /; $noticeccval =~ s/\s+$//;
+
+ my @process= ($ref,split(/ /,$data->{mergedwith}));
+ my $orgref= $ref;
+
+ for $ref (@process) {
+ if ($ref != $orgref) {
+ &unfilelock;
+ $data = &lockreadbug($ref)
+ || die "huh ? $ref from $orgref out of ".join(' ',@process);
+ }
+ $data->{done}= $set_done if defined($set_done);
+ $data->{forwarded}= $set_forwarded if defined($set_forwarded);
+ if ($codeletter eq 'D') {
+ $data->{keywords} = join ' ', grep $_ ne 'pending',
+ split ' ', $data->{keywords};
+ if (defined $pheader{'source-version'}) {
+ if ($pheader{'source-version'} !~ m/^$config{package_version_re}$/) {
+ $brokenness .= fill_template('mail/invalid_version',
+ {version => $pheader{'source-version'}},
+ );
+ }
+ else {
+ addfixedversions($data, $pheader{source}, $pheader{'source-version'}, '');
+ }
+ } elsif (defined $pheader{version}) {
+ if ($pheader{version} !~ m/^$config{package_version_re}$/) {
+ $brokenness .= fill_template('mail/invalid_version',
+ {version => $pheader{version}},
+ );
+ }
+ else {
+ addfixedversions($data, $pheader{package}, $pheader{version}, '');
+ }
+ }
+ }
+
+ # Add bug mailing list to $generalbcc as appropriate
+ # This array is used to specify bcc in the cases where we're using create_mime_message.
+ my @generalbcc = (@generalcc,@addsrcaddrs,"bugs=$ref\@$gListDomain");
+ my $generalbcc = join(', ', $generalcc, @addsrcaddrs,"bugs=$ref\@$gListDomain");
+ $generalbcc =~ s/\s+\n\s+/ /g;
+ $generalbcc =~ s/^\s+/ /; $generalbcc =~ s/\s+$//;
+ if (length $generalbcc) {$generalbcc = "Bcc: $generalbcc\n"};
+
+ writebug($ref, $data);
+
+ my $hash = get_hashname($ref);
+ open(O,"db-h/$hash/$ref.report") || die "read original report: $!";
+ my $orig_report= join('',<O>); close(O);
+ if ($codeletter eq 'F') {
+ &htmllog("Reply","sent",$replyto,"You have marked $gBug as forwarded.");
+ &sendmessage(create_mime_message(
+ ["X-Loop" => "$gMaintainerEmail",
+ From => "$gMaintainerEmail ($gProject $gBug Tracking System)",
+ To => "$replyto",
+ Subject => "$gBug#$ref: marked as forwarded ($data->{subject})",
+ "Message-ID" => "<header.$ref.$nn.ackfwdd\@$gEmailDomain>",
+ "In-Reply-To" => $header{'message-id'},
+ References => join(' ',grep {defined $_} $header{'message-id'},$data->{msgid}),
+ Precedence => 'bulk',
+ "X-$gProject-PR-Message" => "forwarded $ref",
+ "X-$gProject-PR-Package" => $data->{package},
+ "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):(),
+ ],message_body_template('mail/process_mark_as_forwarded',
+ {date => $header{date},
+ messageid => $header{'message-id'},
+ data => $data,
+ },
+ ),
+ [join("\n",@msg)]),'',[$replyto,@generalbcc,@noticecc],1);
+ } else {
+ &htmllog("Reply","sent",$replyto,"You have taken responsibility.");
+ &sendmessage(create_mime_message(
+ ["X-Loop" => "$gMaintainerEmail",
+ From => "$gMaintainerEmail ($gProject $gBug Tracking System)",
+ To => $replyto,
+ Subject => "$gBug#$ref: marked as done ($data->{subject})",
+ "Message-ID" => "<handler.$ref.$nn.ackdone\@$gEmailDomain>",
+ "In-Reply-To" => $header{'message-id'},
+ References => join(' ',grep {defined $_} $header{'message-id'},$data->{msgid}),
+ Precedence => 'bulk',
+ "X-$gProject-PR-Message" => "closed $ref",
+ "X-$gProject-PR-Package" => $data->{package},
+ "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):(),
+ ],message_body_template('mail/process_mark_as_done',
+ {date => $header{date},
+ messageid => $header{'message-id'},
+ subject => $header{subject},
+ data => $data,
+ },
+ ),
+ [$orig_report,join("\n",@msg)]),'',[$replyto,@generalbcc,@noticecc],1);
+ &htmllog("Notification","sent",$data->{originator},
+ "$gBug acknowledged by developer.");
+ &sendmessage(create_mime_message(
+ ["X-Loop" => "$gMaintainerEmail",
+ From => "$gMaintainerEmail ($gProject $gBug Tracking System)",
+ To => "$data->{originator}",
+ Subject => "$gBug#$ref closed by $markedby ($header{'subject'})",
+ "Message-ID" => "<handler.$ref.$nn.notifdone\@$gEmailDomain>",
+ "In-Reply-To" => "$data->{msgid}",
+ References => join(' ',grep {defined $_} $header{'message-id'},$data->{msgid}),
+ "X-$gProject-PR-Message" => "they-closed $ref",
+ "X-$gProject-PR-Package" => "$data->{package}",
+ "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_your_bug_done',
+ {data => $data,
+ markedby => $markedby,
+ messageid => $header{'message-id'},
+ subject => $header{subject},
+ },
+ ),
+ [join("\n",@msg),$orig_report]),'',undef,1);
+ }
+ &appendlog;
+ }
+ &finish;
+}
+
+if ($ref<0) { # new bug report
+ if ($codeletter eq 'U') { # -submitter
+ &htmllog("Warning","sent",$replyto,"Message not forwarded.");
+ &sendmessage(create_mime_message(
+ [From => "$gMaintainerEmail ($gProject $gBug Tracking System)",
+ To => $replyto,
+ Subject => "Message with no $gBug number cannot be sent to submitter! ($subject)",
+ 'Message-ID' => "<handler.x.$nn.nonumnosub\@$gEmailDomain>",
+ 'In-Reply-To' => $header{'message-id'},
+ References => join(' ',grep {defined $_} $header{'message-id'},$data->{msgid}),
+ Precedence => 'bulk',
+ "X-$gProject-PR-Message" => 'error',
+ ],message_body_template('mail/process_no_bug_number',
+ {subject => $subject,
+ date => $header{date},
+ markaswhat => 'submitter',
+ receivedat => "$baddress\@$gEmailDomain",
+ messageid => $header{'message-id'},
+ },
+ )),'');
+ &appendlog;
+ &finish;
+ }
+
+ $data->{found_versions} = [];
+ $data->{fixed_versions} = [];
+
+ if (defined $pheader{source}) {
+ $data->{package} = $pheader{source};
+ } elsif (defined $pheader{package}) {
+ $data->{package} = $pheader{package};
+ } elsif (defined $config{default_package}) {
+ $data->{package} = $config{default_package},
+ }
+ else {
+ &htmllog("Warning","sent",$replyto,"Message not forwarded.");
+ my $body = message_body_template('mail/process_no_package',
+ );
+ &sendmessage(create_mime_message(
+ ["X-Loop" => "$gMaintainerEmail",
+ From => "$gMaintainerEmail ($gProject $gBug Tracking System)",
+ To => $replyto,
+ Subject => "Message with no Package: tag cannot be processed! ($subject)",
+ "Message-ID" => "<handler.x.$nn.nonumnosub\@$gEmailDomain>",
+ "In-Reply-To" => $header{'message-id'},
+ References => join(' ',grep {defined $_} $header{'message-id'},$data->{msgid}),
+ Precedence => 'bulk',
+ "X-$gProject-PR-Message" => 'error'
+ ],
+ message_body_template('mail/process_no_package',
+ {date => $header{date},
+ subject => $subject,
+ messageid => $header{'message-id'},
+ baddress => $baddress,
+ },
+ ),[join("\n", @msg)]), '',undef,1);
+ &appendlog;
+ &finish;
+ }
+
+ if (defined $config{default_package}) {
+ &checkmaintainers;
+ # if there are no maintainers for this package, assign it to the default package
+ if (not @maintaddrs) {
+ $data->{package} = $config{default_package};
+ $brokenness.= fill_template('mail/process_default_package_selected',
+ {old_package => $pheader{source} || $pheader{package} || 'No package',
+ new_package => $data->{package},
+ }
+ );
+ # force the maintainers to be rechecked
+ $maintainerschecked = 0;
+ &checkmaintainers;
+ }
+ }
+
+ $data->{keywords}= '';
+ if (defined($pheader{'keywords'})) {
+ $data->{keywords}= $pheader{'keywords'};
+ } elsif (defined($pheader{'tags'})) {
+ $data->{keywords}= $pheader{'tags'};
+ }
+ if (length($data->{keywords})) {
+ my @kws;
+ my %gkws = map { ($_, 1) } @gTags;
+ foreach my $kw (sort split(/[,\s]+/, lc($data->{keywords}))) {
+ push @kws, $kw if (defined $gkws{$kw});
+ }
+ $data->{keywords} = join(" ", @kws);
+ }
+ $data->{severity}= '';
+ if (defined($pheader{'severity'}) || defined($pheader{'priority'})) {
+ $data->{severity}= $pheader{'severity'};
+ $data->{severity}= $pheader{'priority'} unless ($data->{severity});
+ $data->{severity} =~ s/^\s*(.+)\s*$/$1/;
+
+ if (!grep($_ eq $data->{severity}, @gSeverityList, "$gDefaultSeverity")) {
+ $brokenness.= fill_template('mail/invalid_severity',
+ {severity=>$data->{severity}}
+ );
+ $data->{severity}= '';
+ }
+ }
+ if (defined($pheader{owner})) {
+ $data->{owner}= $pheader{owner};
+ }
+ if (defined($pheader{forwarded})) {
+ $data->{'forwarded-to'} = $pheader{forwarded};
+ }
+ &filelock("nextnumber.lock");
+ open(N,"nextnumber") || die "nextnumber: read: $!";
+ my $nextnumber=<N>; $nextnumber =~ s/\n$// || die "nextnumber bad format";
+ $ref= $nextnumber+0; $nextnumber += 1; $newref=1;
+ &overwrite('nextnumber', "$nextnumber\n");
+ &unfilelock;
+ my $hash = get_hashname($ref);
+ &overwrite("db-h/$hash/$ref.log",'');
+ $data->{originator} = $replyto;
+ $data->{date} = $intdate;
+ $data->{subject} = $subject;
+ $data->{msgid} = $header{'message-id'};
+ writebug($ref, $data);
+ # Deal with usertags
+ if (exists $pheader{usertags}) {
+ my $user = $replyto;
+ $user = $pheader{user} if exists $pheader{user};
+ $user =~ s/,.*//;
+ $user =~ s/^.*<(.*)>.*$/$1/;
+ $user =~ s/[(].*[)]//;
+ $user =~ s/^\s*(\S+)\s+.*$/$1/;
+ if ($user ne '' and Debbugs::User::is_valid_user($user)) {
+ $pheader{usertags} =~ s/(?:^\s+|\s+$)//g;
+ my %user_tags;
+ read_usertags(\%user_tags,$user);
+ for my $tag (split /[,\s]+/, $pheader{usertags}) {
+ if ($tag =~ /^[a-zA-Z0-9.+\@-]+/) {
+ my %bugs_with_tag;
+ @bugs_with_tag{@{$user_tags{$tag}||[]}} = (1) x @{$user_tags{$tag}||[]};
+ $bugs_with_tag{$ref} = 1;
+ $user_tags{$tag} = [keys %bugs_with_tag];
+ }
+ }
+ write_usertags(\%user_tags,$user);
+ }
+ else {
+ $brokenness .= fill_template('mail/invalid_user',
+ {user => $user}
+ );
+ }
+ }
+ &overwrite("db-h/$hash/$ref.report",
+ join("\n",@msg)."\n");
+}
+
+&checkmaintainers;
+
+print DEBUG "maintainers >".join(' ',@maintaddrs)."<\n";
+
+my $orgsender= defined($header{'sender'}) ? "Original-Sender: $header{'sender'}\n" : '';
+my $newsubject= $subject; $newsubject =~ s/^$gBug#$ref:*\s*//;
+
+my $xcchdr= $header{ 'x-debbugs-cc' } || '';
+if ($xcchdr =~ m/\S/) {
+ push(@resentccs,$xcchdr);
+ $resentccexplain.= fill_template('mail/xdebbugscc',
+ {xcchdr => $xcchdr},
+ );
+}
+
+if (@maintaddrs && ($codeletter eq 'B' || $codeletter eq 'M')) {
+ push(@resentccs,@maintaddrs);
+ $resentccexplain.= fill_template('mail/maintainercc',
+ {maintaddrs => \@maintaddrs,
+ },
+ );
+}
+
+@bccs = @addsrcaddrs;
+if (defined $gStrongList and isstrongseverity($data->{severity})) {
+ push @bccs, "$gStrongList\@$gListDomain";
+}
+
+# Send mail to the per bug list subscription too
+push @bccs, "bugs=$ref\@$gListDomain";
+
+if (defined $pheader{source}) {
+ # Prefix source versions with the name of the source package. They
+ # appear that way in version trees so that we can deal with binary
+ # packages moving from one source package to another.
+ if (defined $pheader{'source-version'}) {
+ if ($pheader{'source-version'} !~ m/^$config{package_version_re}$/) {
+ $brokenness .= fill_template('mail/invalid_version',
+ {version => $pheader{'source-version'}},
+ );
+ }
+ else {
+ addfoundversions($data, $pheader{source}, $pheader{'source-version'}, '');
+ }
+ } elsif (defined $pheader{version}) {
+ if ($pheader{version} !~ m/^$config{package_version_re}$/) {
+ $brokenness .= fill_template('mail/invalid_version',
+ {version => $pheader{version}},
+ );
+ }
+ else {
+ addfoundversions($data, $pheader{source}, $pheader{version}, '');
+ }
+ }
+ writebug($ref, $data);
+} elsif (defined $pheader{package}) {
+ # TODO: could handle Source-Version: by looking up the source package?
+ if (defined $pheader{version}) {
+ if ($pheader{version} !~ m/^$config{package_version_re}$/) {
+ $brokenness .= fill_template('mail/invalid_version',
+ {version => $pheader{version}},
+ );
+ }
+ else {
+ addfoundversions($data, $pheader{package}, $pheader{version}, 'binary');
+ }
+ }
+ writebug($ref, $data);
+}
+
+my $veryquiet= $codeletter eq 'Q';
+if ($codeletter eq 'M' && !@maintaddrs) {
+ $veryquiet= 1;
+ $brokenness.= fill_template('mail/invalid_maintainer',
+ {},
+ );
+}
+
+my $resentccval.= join(', ',@resentccs);
+$resentccval =~ s/\s+\n\s+/ /g; $resentccval =~ s/^\s+/ /; $resentccval =~ s/\s+$//;
+my $resentcc = '';
+if (length($resentccval)) {
+ $resentcc= "Resent-CC: $resentccval\n";
+}
+
+if ($codeletter eq 'U') { # sent to -submitter
+ &htmllog("Message", "sent on", $data->{originator}, "$gBug#$ref.");
+ &sendmessage(<<END,[$data->{originator},@resentccs],[@bccs]);
+Subject: $gBug#$ref: $newsubject
+Reply-To: $replyto, $ref-quiet\@$gEmailDomain
+${orgsender}Resent-To: $data->{originator}
+${resentcc}Resent-Date: $tdate
+Resent-Message-ID: <handler.$ref.$nn\@$gEmailDomain>
+Resent-Sender: $gMaintainerEmail
+X-$gProject-PR-Message: report $ref
+X-$gProject-PR-Package: $data->{package}
+X-$gProject-PR-Keywords: $data->{keywords}
+${source_pr_header}$fwd
+END
+} elsif ($codeletter eq 'B') { # Sent to submit
+ my $report_followup = $newref ? 'report' : 'followup';
+ &htmllog($newref ? "Report" : "Information", "forwarded",
+ join(', ',"$gSubmitList\@$gListDomain",@resentccs),
+ "<code>$gBug#$ref</code>".
+ (length($data->{package})? "; Package <code>".html_escape($data->{package})."</code>" : '').
+ ".");
+ &sendmessage(<<END,["$gSubmitList\@$gListDomain",@resentccs],[@bccs]);
+Subject: $gBug#$ref: $newsubject
+Reply-To: $replyto, $ref\@$gEmailDomain
+Resent-From: $header{'from'}
+${orgsender}Resent-To: $gSubmitList\@$gListDomain
+${resentcc}Resent-Date: $tdate
+Resent-Message-ID: <handler.$ref.$nn\@$gEmailDomain>
+Resent-Sender: $gMaintainerEmail
+X-$gProject-PR-Message: $report_followup $ref
+X-$gProject-PR-Package: $data->{package}
+X-$gProject-PR-Keywords: $data->{keywords}
+${source_pr_header}$fwd
+END
+} elsif (@resentccs or @bccs) { # Quiet or Maintainer
+ # D and F done far earlier; B just done - so this must be M or Q
+ # We preserve whichever it was in the Reply-To (possibly adding
+ # the $gBug#).
+ my $report_followup = $newref ? 'report' : 'followup';
+ if (@resentccs) {
+ &htmllog($newref ? "Report" : "Information", "forwarded",
+ $resentccval,
+ "<code>$gBug#$ref</code>".
+ (length($data->{package}) ? "; Package <code>".html_escape($data->{package})."</code>" : '').
+ ".");
+ } else {
+ &htmllog($newref ? "Report" : "Information", "stored",
+ "",
+ "<code>$gBug#$ref</code>".
+ (length($data->{package}) ? "; Package <code>".html_escape($data->{package})."</code>" : '').
+ ".");
+ }
+ &sendmessage(<<END,[@resentccs],[@bccs]);
+Subject: $gBug#$ref: $newsubject
+Reply-To: $replyto, $ref-$baddressroot\@$gEmailDomain
+Resent-From: $header{'from'}
+${orgsender}Resent-To: $resentccval
+Resent-Date: $tdate
+Resent-Message-ID: <handler.$ref.$nn\@$gEmailDomain>
+Resent-Sender: $gMaintainerEmail
+X-$gProject-PR-Message: $report_followup $ref
+X-$gProject-PR-Package: $data->{package}
+X-$gProject-PR-Keywords: $data->{keywords}
+${source_pr_header}$fwd
+END
+}
+
+my $htmlbreak= length($brokenness) ? "<p>\n".html_escape($brokenness)."\n<p>\n" : '';
+$htmlbreak =~ s/\n\n/\n<P>\n\n/g;
+if (length($resentccval)) {
+ $htmlbreak = " Copy sent to <code>".html_escape($resentccval)."</code>.".
+ $htmlbreak;
+}
+
+# Should we send an ack out?
+if (not exists $header{'x-debbugs-no-ack'} and
+ ($newref or
+ ($codeletter ne 'U' and
+ (not defined $header{precedence} or
+ $header{'precedence'} !~ /\b(?:bulk|junk|list)\b/
+ )
+ )
+ )
+ ){
+
+ # figure out forward explanation
+ my $forwardexplain = '';
+ my $thanks = '';
+ my $extra_vars;
+ # will contain info and -info in moreinfo messages
+ my $info = '';
+ my $infod = '';
+ # temporary headers
+ my %t_h;
+ if ($newref) {
+ &htmllog("Acknowledgement","sent",$replyto,
+ ($veryquiet ?
+ "New $gBug report received and filed, but not forwarded." :
+ "New $gBug report received and forwarded."). $htmlbreak);
+ $thanks = fill_template('mail/process_ack_thanks_new');
+ }
+ else {
+ &htmllog("Acknowledgement","sent",$replyto,
+ ($veryquiet ? "Extra info received and filed, but not forwarded." :
+ $codeletter eq 'M' ? "Extra info received and forwarded to maintainer." :
+ "Extra info received and forwarded to list."). $htmlbreak);
+ $thanks = fill_template('mail/process_ack_thanks_additional');
+ $info = 'info';
+ $infod = '-info';
+ }
+ if ($veryquiet) {
+ $forwardexplain = fill_template('mail/forward_veryquiet',
+ );
+ # these are the headers that quiet messages override
+ $t_h{messageid} = "<handler.$ref.$nn.ack${info}quiet\@$gEmailDomain>";
+ $t_h{pr_message} = "ack${infod}-quiet $ref";
+ $t_h{reply_to} = "$ref-quiet\@$gEmailDomain";
+ $extra_vars->{refreplyto} = "$ref-quiet\@$gEmailDomain";
+ $t_h{subject} = length($info)?
+ "$gBug#$ref: Info received and FILED only ($subject)":
+ "$gBug#$ref: Acknowledgement of QUIET report ($subject)";
+ }
+ elsif ($codeletter eq 'M') {
+ $forwardexplain = fill_template('mail/forward_maintonly',
+ );
+ # these are the headers that maintonly messages override
+ $t_h{messageid} = "<handler.$ref.$nn.ack{$info}maintonly\@$gEmailDomain>";
+ $t_h{pr_message} = "ack${infod}-maintonly $ref";
+ $t_h{reply_to} = "$ref-maintonly\@$gEmailDomain";
+ $extra_vars->{refreplyto} = "$ref-maintonly\@$gEmailDomain";
+ $t_h{subject} = length($info)?
+ "$gBug#$ref: Info received for maintainer only ($subject)":
+ "$gBug#$ref: Acknowledgement of maintainer-only report ($subject)";
+ }
+ else {
+ $forwardexplain = fill_template('mail/forward_normal',
+ );
+ $t_h{messageid} = "<handler.$ref.$nn.ack${info}\@$gEmailDomain>";
+ $t_h{pr_message} = "ack${infod} $ref";
+ $t_h{reply_to} = "$ref\@$gEmailDomain";
+ $extra_vars->{refreplyto} = "$ref\@$gEmailDomain";
+ $t_h{subject} = (defined $info and length($info))?
+ "$gBug#$ref: Info received ($subject)" :
+ "$gBug#$ref: Acknowledgement ($subject)";
+ }
+ my $body = message_body_template('mail/process_ack',
+ {forwardexplain => $forwardexplain,
+ resentccexplain => $resentccexplain,
+ thanks => $thanks,
+ %{$extra_vars}
+ }
+ );
+ &sendmessage(create_mime_message(
+ ["X-Loop" => "$gMaintainerEmail",
+ From => "$gMaintainerEmail ($gProject $gBug Tracking System)",
+ To => $replyto,
+ Subject => $t_h{subject},
+ "Message-ID" => $t_h{messageid},
+ "In-Reply-To" => $header{'message-id'},
+ References => $header{'message-id'},
+ Precedence => 'bulk',
+ "X-$gProject-PR-Message" => $t_h{pr_message} || "ack $ref",
+ "X-$gProject-PR-Package" => $data->{package},
+ "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" => $t_h{reply_to} || "$ref\@$gEmailDomain",
+ ],$body,[]), '',undef,1);
+}
+
+&appendlog;
+&finish;
+
+sub overwrite {
+ my ($f,$v) = @_;
+ open(NEW,">$f.new") || die "$f.new: create: $!";
+ print(NEW "$v") || die "$f.new: write: $!";
+ close(NEW) || die "$f.new: close: $!";
+ rename("$f.new","$f") || die "rename $f.new to $f: $!";
+}
+
+sub appendlog {
+ my $hash = get_hashname($ref);
+ if (!open(AP,">>db-h/$hash/$ref.log")) {
+ print DEBUG "failed open log<\n";
+ print DEBUG "failed open log err $!<\n";
+ die "opening db-h/$hash/$ref.log (li): $!";
+ }
+ print(AP "\7\n",escape_log(@log),"\n\3\n") || die "writing db-h/$hash/$ref.log (li): $!";
+ close(AP) || die "closing db-h/$hash/$ref.log (li): $!";
+}
+
+sub finish {
+ my ($exit) = @_;
+ $exit ||= 0;
+ utime(time,time,"db");
+ # cleanups are run in an end block now.
+ #my ($u);
+ #while ($u= $cleanups[$#cleanups]) { &$u; }
+ unlink("incoming/P$nn") || die "unlinking incoming/P$nn: $!";
+ exit $exit;
+}
+
+die "wot no exit";
+
+sub htmllog {
+ my ($whatobj,$whatverb,$where,$desc) = @_;
+ my $hash = get_hashname($ref);
+ open(AP,">>db-h/$hash/$ref.log") || die "opening db-h/$hash/$ref.log (lh): $!";
+ print(AP
+ "\6\n".
+ "<strong>$whatobj $whatverb</strong>".
+ ($where eq '' ? "" : " to <code>".html_escape($where)."</code>").
+ ":<br>\n". $desc.
+ "\n\3\n") || die "writing db-h/$hash/$ref.log (lh): $!";
+ close(AP) || die "closing db-h/$hash/$ref.log (lh): $!";
+}
+
+sub stripbccs {
+ my $msg = shift;
+ my $ret = '';
+ my $bcc = 0;
+ while ($msg =~ s/(.*\n)//) {
+ local $_ = $1;
+ if (/^$/) {
+ $ret .= $_;
+ last;
+ }
+ if ($bcc) {
+ # strip continuation lines too
+ next if /^\s/;
+ $bcc = 0;
+ }
+ if (/^Bcc:/i) {
+ $bcc = 1;
+ } else {
+ $ret .= $_;
+ }
+ }
+ return $ret . $msg;
+}
+
+=head2 send_message
+
+ send_message($the_message,\@recipients,\@bcc,$do_not_encode)
+
+The first argument is the scalar message, the second argument is the
+arrayref of recipients, the third is the arrayref of Bcc:'ed
+recipients.
+
+The final argument turns off header encoding and the addition of the
+X-Loop header if true, defaults to false.
+
+=cut
+
+
+sub sendmessage {
+ my ($msg,$recips,$bcc,$no_encode) = @_;
+ if (not defined $recips or (!ref($recips) && $recips eq '')
+ or @$recips == 0) {
+ $recips = ['-t'];
+ }
+ # This is suboptimal. The right solution is to send headers
+ # separately from the rest of the message and encode them rather
+ # than doing this.
+ $msg = "X-Loop: $gMaintainerEmail\n" . $msg unless $no_encode;
+ # The original message received is written out in appendlog, so
+ # before writing out the other messages we've sent out, we need to
+ # RFC1522 encode the header.
+ $msg = encode_headers($msg) unless $no_encode;
+
+ my $hash = get_hashname($ref);
+ #save email to the log
+ open(AP,">>db-h/$hash/$ref.log") || die "opening db-h/$hash/$ref.log (lo): $!";
+ print(AP "\2\n",join("\4",@$recips),"\n\5\n",
+ escape_log(stripbccs($msg)),"\n\3\n") ||
+ die "writing db-h/$hash/$ref.log (lo): $!";
+ close(AP) || die "closing db-h/$hash/$ref.log (lo): $!";
+
+ if (ref($bcc)) {
+ shift @$recips if $recips->[0] eq '-t';
+ push @$recips, @$bcc;
+ }
+
+ send_mail_message(message => $msg,
+ # Because we encode the headers above, we do not want to encode them here
+ encode_headers => 0,
+ recipients => $recips);
+}
+
+=head2 message_body_template
+
+ message_body_template('mail/ack',{ref=>'foo'});
+
+Creates a message body using a template
+
+=cut
+
+sub message_body_template{
+ my ($template,$extra_var) = @_;
+ $extra_var ||={};
+ my $body = fill_template($template,$extra_var);
+ return fill_template('mail/message_body',
+ {%{$extra_var},
+ body => $body,
+ },
+ );
+}
+
+=head2 fill_template
+
+ fill_template('mail/foo',{foo=>'bar'});
+
+Calls fill_in_template with a default set of variables and any extras
+added in.
+
+=cut
+
+sub fill_template{
+ my ($template,$extra_var) = @_;
+ $extra_var ||={};
+ my $variables = {config => \%config,
+ defined($ref)?(ref => $ref):(),
+ defined($data)?(data => $data):(),
+ %{$extra_var},
+ };
+ my $hole_var = {'&bugurl' =>
+ sub{"$_[0]: ".
+ 'http://'.$config{cgi_domain}.'/'.
+ Debbugs::CGI::bug_links(bug=>$_[0],
+ links_only => 1,
+ );
+ }
+ };
+ return fill_in_template(template => $template,
+ variables => $variables,
+ hole_var => $hole_var,
+ );
+}
+
+
+sub checkmaintainers {
+ return if $maintainerschecked++;
+ return if !length($data->{package});
+ my %maintainerof;
+ open(MAINT,"$gMaintainerFile") || die die "maintainers open: $!";
+ while (<MAINT>) {
+ m/^\n$/ && next;
+ m/^\s*$/ && next;
+ m/^(\S+)\s+(\S.*\S)\s*\n$/ || die "maintainers bogus \`$_'";
+ $a= $1; $b= $2; $a =~ y/A-Z/a-z/;
+ # use the package which is normalized to lower case; we do this because we lc the pseudo headers.
+ $maintainerof{$a}= $2;
+ }
+ close(MAINT);
+ open(MAINT,"$gMaintainerFileOverride") || die die "maintainers.override open: $!";
+ while (<MAINT>) {
+ m/^\n$/ && next;
+ m/^\s*$/ && next;
+ m/^(\S+)\s+(\S.*\S)\s*\n$/ || die "maintainers.override bogus \`$_'";
+ $a= $1; $b= $2; $a =~ y/A-Z/a-z/;
+ # use the package which is normalized to lower case; we do this because we lc the pseudo headers.
+ $maintainerof{$a}= $2;
+ }
+ close(MAINT);
+ my %pkgsrc;
+ open(SOURCES,"$gPackageSource") || die "pkgsrc open: $!";
+ while (<SOURCES>) {
+ next unless m/^(\S+)\s+\S+\s+(\S.*\S)\s*$/;
+ ($a,$b)=($1,$2);
+ $a =~ y/A-Z/a-z/;
+ $pkgsrc{$a} = $b;
+ }
+ close(SOURCES);
+ my $anymaintfound=0; my $anymaintnotfound=0;
+ for my $p (split(m/[ \t?,():]+/,$data->{package})) {
+ $p =~ y/A-Z/a-z/;
+ $p =~ /([a-z0-9.+-]+)/;
+ $p = $1;
+ next unless defined $p;
+ if (defined $gSubscriptionDomain) {
+ if (defined($pkgsrc{$p})) {
+ push @addsrcaddrs, "$pkgsrc{$p}\@$gSubscriptionDomain";
+ } else {
+ push @addsrcaddrs, "$p\@$gSubscriptionDomain";
+ }
+ }
+ if (defined($maintainerof{$p})) {
+ print DEBUG "maintainer add >$p|$maintainerof{$p}<\n";
+ my $addmaint= $maintainerof{$p};
+ push(@maintaddrs,$addmaint) unless
+ $addmaint eq $replyto || grep($_ eq $addmaint, @maintaddrs);
+ $anymaintfound++;
+ } else {
+ print DEBUG "maintainer none >$p<\n";
+ push(@maintaddrs,$gUnknownMaintainerEmail) unless $anymaintnotfound;
+ $anymaintnotfound++;
+ last;
+ }
+ }
+
+ if (defined $data->{owner} and length $data->{owner}) {
+ print DEBUG "owner add >$data->{package}|$data->{owner}<\n";
+ my $addmaint = $data->{owner};
+ push(@maintaddrs, $addmaint) unless
+ $addmaint eq $replyto or grep($_ eq $addmaint, @maintaddrs);
+ }
+}
+
+=head2 bug_list_forward
+
+ bug_list_forward($spool_filename) if $codeletter eq 'L';
+
+
+Given the spool file, will forward a bug to the per bug mailing list
+subscription system.
+
+=cut
+
+sub bug_list_forward{
+ my ($bug_fn) = @_;
+ # Read the bug information and package information for passing to
+ # the mailing list
+ my ($bug_number) = $bug_fn =~ /^L(\d+)\./;
+ my ($bfound, $data)= lockreadbugmerge($bug_number);
+ my $bug_fh = IO::File->new("incoming/P$bug_fn",'r') or die "Unable to open incoming/P$bug_fn $!";
+
+ local $/ = undef;
+ my $bug_message = <$bug_fh>;
+ my ($bug_address) = $bug_message =~ /^Received: \(at ([^\)]+)\) by/;
+ my ($envelope_from) = $bug_message =~ s/\nFrom\s+([^\s]+)[^\n]+\n/\n/;
+ if (not defined $envelope_from) {
+ # Try to use the From: header or something to set it
+ ($envelope_from) = $bug_message =~ /\nFrom:\s+(.+?)\n/;
+ # Kludgy, and should really be using a full scale header
+ # parser to do this.
+ $envelope_from =~ s/^.+?<([^>]+)>.+$/$1/;
+ }
+ my ($header,$body) = split /\n\n/, $bug_message, 2;
+ # Add X-$gProject-PR-Message: list bug_number, package name, and bug title headers
+ $header .= qq(\nX-$gProject-PR-Message: list $bug_number\n).
+ qq(X-$gProject-PR-Package: $data->{package}\n).
+ qq(X-$gProject-PR-Title: $data->{subject})
+ if defined $data;
+ print STDERR "Tried to loop me with $envelope_from\n"
+ and exit 1 if $envelope_from =~ /\Q$gListDomain\E|\Q$gEmailDomain\E/;
+ print DEBUG $envelope_from,qq(\n);
+ # If we don't have a bug address, something has gone horribly wrong.
+ print STDERR "Doesn't match: $bug_address\n" and exit 1 unless defined $bug_address;
+ $bug_address =~ s/\@.+//;
+ print DEBUG "Sending message to bugs=$bug_address\@$gListDomain\n";
+ print DEBUG $header.qq(\n\n).$body;
+ send_mail_message(message => $header.qq(\n\n).$body,
+ recipients => ["bugs=$bug_address\@$gListDomain"],
+ envelope_from => $envelope_from,
+ encode_headers => 0,
+ );
+ unlink("incoming/P$bug_fn") || die "unlinking incoming/P$bug_fn: $!";
+ exit 0;
+}
+++ /dev/null
-#!/usr/bin/perl
-# $Id: process.in,v 1.109 2006/02/09 22:02:04 don Exp $
-#
-# Usage: process nn
-# Temps: incoming/Pnn
-
-use warnings;
-use strict;
-
-use POSIX qw(strftime);
-
-use IO::File;
-
-use MIME::Parser;
-use Debbugs::MIME qw(decode_rfc1522 create_mime_message getmailbody);
-use Debbugs::Mail qw(send_mail_message encode_headers);
-use Debbugs::Packages qw(getpkgsrc);
-use Debbugs::User qw(read_usertags write_usertags);
-use Debbugs::Common qw(:lock get_hashname);
-use Debbugs::Status qw(writebug isstrongseverity lockreadbugmerge lockreadbug);
-
-use Debbugs::CGI qw(html_escape bug_url);
-
-use Debbugs::Log qw(:misc);
-
-use Debbugs::Text qw(:templates);
-
-use Debbugs::Status qw(:versions);
-use Debbugs::Config qw(:globals :config);
-
-chdir( "$gSpoolDir" ) || die "chdir spool: $!\n";
-
-#open(DEBUG,"> /tmp/debbugs.debug");
-umask(002);
-open DEBUG, ">/dev/null";
-
-my $intdate = time or quit("failed to get time: $!");
-
-$_=shift;
-m/^([BMQFDUL])(\d*)\.\d+$/ or quit("bad argument: $_");
-my $codeletter= $1;
-my $tryref= length($2) ? $2 : -1;
-my $nn= $_;
-
-if (!rename("incoming/G$nn","incoming/P$nn"))
-{
- $_=$!.''; m/no such file or directory/i && exit 0;
- &quit("renaming to lock: $!");
-}
-
-my $baddress= 'submit' if $codeletter eq 'B';
-$baddress= 'maintonly' if $codeletter eq 'M';
-$baddress= 'quiet' if $codeletter eq 'Q';
-$baddress= 'forwarded' if $codeletter eq 'F';
-$baddress= 'done' if $codeletter eq 'D';
-$baddress= 'submitter' if $codeletter eq 'U';
-bug_list_forward($nn) if $codeletter eq 'L';
-$baddress || &quit("bad codeletter $codeletter");
-my $baddressroot= $baddress;
-$baddress= "$tryref-$baddress" if $tryref>=0;
-
-open(M,"incoming/P$nn");
-my @log=<M>;
-close(M);
-
-my @msg = @log;
-chomp @msg;
-
-print DEBUG "###\n",join("##\n",@msg),"\n###\n";
-
-my $tdate = strftime "%a, %d %h %Y %T +0000", gmtime;
-my $fwd= <<END;
-Received: via spool by $baddress\@$gEmailDomain id=$nn
- (code $codeletter ref $tryref); $tdate
-END
-
-# header and decoded body respectively
-my (@headerlines, @bodylines);
-
-# whether maintainer addresses have been checked
-our $maintainerschecked = 0;
-#maintainer address for this message
-our @maintaddrs;
-# other src addresses
-our @addsrcaddrs;
-our @resentccs;
-our @bccs;
-
-my $resentccexplain='';
-
-# whether there's a new reference with this email
-our $newref = 0;
-
-our $brokenness = '';
-
-my $parser = new MIME::Parser;
-mkdir "$gSpoolDir/mime.tmp", 0777;
-$parser->output_under("$gSpoolDir/mime.tmp");
-my $entity = eval { $parser->parse_data(join('',@log)) };
-
-my $i;
-if ($entity and $entity->head->tags) {
- @headerlines = @{$entity->head->header};
- chomp @headerlines;
-
- my $entity_body = getmailbody($entity);
- @bodylines = map {s/\r?\n$//; $_;}
- $entity_body ? $entity_body->as_lines() : ();
-
- # set $i to beginning of encoded body data, so we can dump it out
- # verbatim later
- $i = 0;
- ++$i while $msg[$i] =~ /./;
-} else {
- # Legacy pre-MIME code, kept around in case MIME::Parser fails.
- for ($i = 0; $i <= $#msg; $i++) {
- $_ = $msg[$i];
- last unless length($_);
- while ($msg[$i+1] =~ m/^\s/) {
- $i++;
- $_ .= "\n".$msg[$i];
- }
- push @headerlines, $_;
- }
-
- @bodylines = @msg[$i..$#msg];
-}
-
-my %header;
-
-for my $hdr (@headerlines) {
- $hdr = decode_rfc1522($hdr);
- $_ = $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;
- $fwd .= $hdr."\n" if $ins;
- # print DEBUG ">$_<\n";
- if (s/^(\S+):\s*//) {
- my $v = lc $1;
- print DEBUG ">$v=$_<\n";
- $header{$v} = $_;
- } else {
- print DEBUG "!>$_<\n";
- }
-}
-$header{'message-id'} = '' if not defined $header{'message-id'};
-
-# remove blank lines
-shift @bodylines while @bodylines and $bodylines[0] !~ /\S/;
-
-# Strip off RFC2440-style PGP clearsigning.
-if (@bodylines and $bodylines[0] =~ /^-----BEGIN PGP SIGNED/) {
- shift @bodylines while @bodylines and length $bodylines[0];
- shift @bodylines while @bodylines and $bodylines[0] !~ /\S/;
- for my $findsig (0 .. $#bodylines) {
- if ($bodylines[$findsig] =~ /^-----BEGIN PGP SIGNATURE/) {
- $#bodylines = $findsig - 1;
- last;
- }
- }
- map { s/^- // } @bodylines;
-}
-
-#psuedoheaders
-my %pheader;
-# extract pseudo-headers
-for my $phline (@bodylines)
-{
- last if $phline !~ m/^([\w-]+):\s*(\S.*)/;
- my ($fn, $fv) = ($1, $2);
- $fv =~ s/\s*$//;
- print DEBUG ">$fn|$fv|\n";
- $fn = lc $fn;
- # Don't lc owner or forwarded
- $fv = lc $fv unless $fn =~ /^(?:owner|forwarded|usertags|version|source-version)$/;
- $pheader{$fn} = $fv;
- print DEBUG ">$fn~$fv<\n";
-}
-
-# Allow pseudo headers to set x-debbugs- stuff [#179340]
-for my $key (grep /X-Debbugs-.*/i, keys %pheader) {
- $header{$key} = $pheader{$key} if not exists $header{$key};
-}
-
-$fwd .= join("\n",@msg[$i..$#msg]);
-
-print DEBUG "***\n$fwd\n***\n";
-
-if (defined $header{'resent-from'} && !defined $header{'from'}) {
- $header{'from'} = $header{'resent-from'};
-}
-defined($header{'from'}) || &quit("no From header");
-
-my $replyto = $header{'reply-to'};
-$replyto = '' unless defined $replyto;
-$replyto =~ s/^ +//;
-$replyto =~ s/ +$//;
-unless (length $replyto) {
- $replyto = $header{'from'};
-}
-
-my $subject = '(no subject)';
-if (!defined($header{'subject'}))
-{
- $brokenness.= fill_template('mail/process_broken_subject');
-
-} else {
- $subject= $header{'subject'};
-}
-
-my $ref=-1;
-$subject =~ s/^Re:\s*//i; $_= $subject."\n";
-if ($tryref < 0 && m/^Bug ?\#(\d+)\D/i) {
- $tryref= $1+0;
-}
-my $data;
-if ($tryref >= 0)
-{
- my $bfound;
- ($bfound, $data)= &lockreadbugmerge($tryref);
- if ($bfound) {
- $ref= $tryref;
- } else {
- &htmllog("Reply","sent", $replyto,"Unknown problem report number <code>$tryref</code>.");
- &sendmessage(create_mime_message(
- [From => "$gMaintainerEmail ($gProject $gBug Tracking System)",
- To => $replyto,
- Subject => "Unknown problem report $gBug#$tryref ($subject)",
- 'Message-ID' => "<handler.x.$nn.unknown\@$gEmailDomain>",
- 'In-Reply-To' => $header{'message-id'},
- References => join(' ',grep {defined $_} $header{'message-id'},$data->{msgid}),
- Precedence => 'bulk',
- "X-$gProject-PR-Message" => 'error',
- ],message_body_template('process_unknown_bug_number',
- {subject => $subject,
- date => $header{date},
- baddress => $baddress,
- tryref => $tryref,
- messageid => $header{'message-id'},
- },
- )),'');
- &appendlog;
- &finish;
- }
-} else {
- &filelock('lock/-1');
-}
-
-# Attempt to determine which source package this is
-my $source_pr_header = '';
-my $source_package = '';
-if (defined $pheader{source}) {
- $source_package = $pheader{source};
-}
-elsif (defined $data->{package} or defined $pheader{package}) {
- my $pkg_src = getpkgsrc();
- $source_package = $pkg_src->{defined $data->{package}?$data->{package}:$pheader{package}};
-}
-$source_pr_header = "X-$gProject-PR-Source: $source_package\n"
- if defined $source_package and length $source_package;
-
-# Done and Forwarded Bugs
-if ($codeletter eq 'D' || $codeletter eq 'F')
-{
- if ($replyto =~ m/$gBounceFroms/o ||
- $header{'from'} =~ m/$gBounceFroms/o)
- {
- print STDERR "bounce detected ! Mwaap! Mwaap!";
- exit 1;
- }
- my $markedby= $header{'from'} eq $replyto ? $replyto :
- "$header{'from'} (reply to $replyto)";
- my @generalcc;
- my $receivedat;
- my $markaswhat;
- my $set_forwarded;
- my $generalcc;
- my $set_done;
- if ($codeletter eq 'F') { # Forwarded
- (&appendlog,&finish) if defined $data->{forwarded} and length($data->{forwarded});
- $receivedat= "forwarded\@$gEmailDomain";
- $markaswhat= 'forwarded';
- $set_forwarded= $header{'to'};
- # Dissallow forwarded being set to this bug tracking system
- if (defined $set_forwarded and $set_forwarded =~ /\Q$gEmailDomain\E/) {
- undef $set_forwarded;
- }
- if ( length( $gListDomain ) > 0 && length( $gForwardList ) > 0 ) {
- push @generalcc, "$gForwardList\@$gListDomain";
- $generalcc= "$gForwardList\@$gListDomain";
- } else {
- $generalcc='';
- }
- } else { # Done
- if (defined $data->{done} and length($data->{done}) and
- not defined $pheader{'source-version'} and
- not defined $pheader{'version'}) {
- &appendlog;
- &finish;
- }
- $receivedat= "done\@$gEmailDomain";
- $markaswhat= 'done';
- $set_done= $header{'from'};
- if ( length( $gListDomain ) > 0 && length( $gDoneList ) > 0 ) {
- $generalcc= "$gDoneList\@$gListDomain";
- push @generalcc, "$gDoneList\@$gListDomain";
- } else {
- $generalcc='';
- }
- }
- if (defined $gStrongList and isstrongseverity($data->{severity})) {
- $generalcc = join ', ', $generalcc, "$gStrongList\@$gListDomain";
- push @generalcc,"$gStrongList\@$gListDomain";
- }
- if ($ref<0) {
- &htmllog("Warning","sent",$replyto,"Message ignored.");
- &sendmessage(create_mime_message(
- [From => "$gMaintainerEmail ($gProject $gBug Tracking System)",
- To => $replyto,
- Subject => "Message with no $gBug number ignored by $receivedat ($subject)",
- 'Message-ID' => "<handler.x.$nn.warnignore\@$gEmailDomain>",
- 'In-Reply-To' => $header{'message-id'},
- References => join(' ',grep {defined $_} $header{'message-id'},$data->{msgid}),
- Precedence => 'bulk',
- "X-$gProject-PR-Message" => 'error',
- ],message_body_template('mail/process_no_bug_number',
- {subject => $subject,
- date => $header{date},
- markaswhat => $markaswhat,
- receivedat => $receivedat,
- messageid => $header{'message-id'},
- },
- )),'');
- &appendlog;
- &finish;
- }
-
- &checkmaintainers;
-
- my @noticecc = grep($_ ne $replyto,@maintaddrs);
- my $noticeccval.= join(', ', grep($_ ne $replyto,@maintaddrs));
- $noticeccval =~ s/\s+\n\s+/ /g;
- $noticeccval =~ s/^\s+/ /; $noticeccval =~ s/\s+$//;
-
- my @process= ($ref,split(/ /,$data->{mergedwith}));
- my $orgref= $ref;
-
- for $ref (@process) {
- if ($ref != $orgref) {
- &unfilelock;
- $data = &lockreadbug($ref)
- || die "huh ? $ref from $orgref out of ".join(' ',@process);
- }
- $data->{done}= $set_done if defined($set_done);
- $data->{forwarded}= $set_forwarded if defined($set_forwarded);
- if ($codeletter eq 'D') {
- $data->{keywords} = join ' ', grep $_ ne 'pending',
- split ' ', $data->{keywords};
- if (defined $pheader{'source-version'}) {
- if ($pheader{'source-version'} !~ m/^$config{package_version_re}$/) {
- $brokenness .= fill_template('mail/invalid_version',
- {version => $pheader{'source-version'}},
- );
- }
- else {
- addfixedversions($data, $pheader{source}, $pheader{'source-version'}, '');
- }
- } elsif (defined $pheader{version}) {
- if ($pheader{version} !~ m/^$config{package_version_re}$/) {
- $brokenness .= fill_template('mail/invalid_version',
- {version => $pheader{version}},
- );
- }
- else {
- addfixedversions($data, $pheader{package}, $pheader{version}, '');
- }
- }
- }
-
- # Add bug mailing list to $generalbcc as appropriate
- # This array is used to specify bcc in the cases where we're using create_mime_message.
- my @generalbcc = (@generalcc,@addsrcaddrs,"bugs=$ref\@$gListDomain");
- my $generalbcc = join(', ', $generalcc, @addsrcaddrs,"bugs=$ref\@$gListDomain");
- $generalbcc =~ s/\s+\n\s+/ /g;
- $generalbcc =~ s/^\s+/ /; $generalbcc =~ s/\s+$//;
- if (length $generalbcc) {$generalbcc = "Bcc: $generalbcc\n"};
-
- writebug($ref, $data);
-
- my $hash = get_hashname($ref);
- open(O,"db-h/$hash/$ref.report") || &quit("read original report: $!");
- my $orig_report= join('',<O>); close(O);
- if ($codeletter eq 'F') {
- &htmllog("Reply","sent",$replyto,"You have marked $gBug as forwarded.");
- &sendmessage(create_mime_message(
- ["X-Loop" => "$gMaintainerEmail",
- From => "$gMaintainerEmail ($gProject $gBug Tracking System)",
- To => "$replyto",
- Subject => "$gBug#$ref: marked as forwarded ($data->{subject})",
- "Message-ID" => "<header.$ref.$nn.ackfwdd\@$gEmailDomain>",
- "In-Reply-To" => $header{'message-id'},
- References => join(' ',grep {defined $_} $header{'message-id'},$data->{msgid}),
- Precedence => 'bulk',
- "X-$gProject-PR-Message" => "forwarded $ref",
- "X-$gProject-PR-Package" => $data->{package},
- "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):(),
- ],message_body_template('mail/process_mark_as_forwarded',
- {date => $header{date},
- messageid => $header{'message-id'},
- data => $data,
- },
- ),
- [join("\n",@msg)]),'',[$replyto,@generalbcc,@noticecc],1);
- } else {
- &htmllog("Reply","sent",$replyto,"You have taken responsibility.");
- &sendmessage(create_mime_message(
- ["X-Loop" => "$gMaintainerEmail",
- From => "$gMaintainerEmail ($gProject $gBug Tracking System)",
- To => $replyto,
- Subject => "$gBug#$ref: marked as done ($data->{subject})",
- "Message-ID" => "<handler.$ref.$nn.ackdone\@$gEmailDomain>",
- "In-Reply-To" => $header{'message-id'},
- References => join(' ',grep {defined $_} $header{'message-id'},$data->{msgid}),
- Precedence => 'bulk',
- "X-$gProject-PR-Message" => "closed $ref",
- "X-$gProject-PR-Package" => $data->{package},
- "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):(),
- ],message_body_template('mail/process_mark_as_done',
- {date => $header{date},
- messageid => $header{'message-id'},
- subject => $header{subject},
- data => $data,
- },
- ),
- [$orig_report,join("\n",@msg)]),'',[$replyto,@generalbcc,@noticecc],1);
- &htmllog("Notification","sent",$data->{originator},
- "$gBug acknowledged by developer.");
- &sendmessage(create_mime_message(
- ["X-Loop" => "$gMaintainerEmail",
- From => "$gMaintainerEmail ($gProject $gBug Tracking System)",
- To => "$data->{originator}",
- Subject => "$gBug#$ref closed by $markedby ($header{'subject'})",
- "Message-ID" => "<handler.$ref.$nn.notifdone\@$gEmailDomain>",
- "In-Reply-To" => "$data->{msgid}",
- References => join(' ',grep {defined $_} $header{'message-id'},$data->{msgid}),
- "X-$gProject-PR-Message" => "they-closed $ref",
- "X-$gProject-PR-Package" => "$data->{package}",
- "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_your_bug_done',
- {data => $data,
- markedby => $markedby,
- messageid => $header{'message-id'},
- subject => $header{subject},
- },
- ),
- [join("\n",@msg),$orig_report]),'',undef,1);
- }
- &appendlog;
- }
- &finish;
-}
-
-if ($ref<0) { # new bug report
- if ($codeletter eq 'U') { # -submitter
- &htmllog("Warning","sent",$replyto,"Message not forwarded.");
- &sendmessage(create_mime_message(
- [From => "$gMaintainerEmail ($gProject $gBug Tracking System)",
- To => $replyto,
- Subject => "Message with no $gBug number cannot be sent to submitter! ($subject)",
- 'Message-ID' => "<handler.x.$nn.nonumnosub\@$gEmailDomain>",
- 'In-Reply-To' => $header{'message-id'},
- References => join(' ',grep {defined $_} $header{'message-id'},$data->{msgid}),
- Precedence => 'bulk',
- "X-$gProject-PR-Message" => 'error',
- ],message_body_template('mail/process_no_bug_number',
- {subject => $subject,
- date => $header{date},
- markaswhat => 'submitter',
- receivedat => "$baddress\@$gEmailDomain",
- messageid => $header{'message-id'},
- },
- )),'');
- &appendlog;
- &finish;
- }
-
- $data->{found_versions} = [];
- $data->{fixed_versions} = [];
-
- if (defined $pheader{source}) {
- $data->{package} = $pheader{source};
- } elsif (defined $pheader{package}) {
- $data->{package} = $pheader{package};
- } elsif (defined $config{default_package}) {
- $data->{package} = $config{default_package},
- }
- else {
- &htmllog("Warning","sent",$replyto,"Message not forwarded.");
- my $body = message_body_template('mail/process_no_package',
- );
- &sendmessage(create_mime_message(
- ["X-Loop" => "$gMaintainerEmail",
- From => "$gMaintainerEmail ($gProject $gBug Tracking System)",
- To => $replyto,
- Subject => "Message with no Package: tag cannot be processed! ($subject)",
- "Message-ID" => "<handler.x.$nn.nonumnosub\@$gEmailDomain>",
- "In-Reply-To" => $header{'message-id'},
- References => join(' ',grep {defined $_} $header{'message-id'},$data->{msgid}),
- Precedence => 'bulk',
- "X-$gProject-PR-Message" => 'error'
- ],
- message_body_template('mail/process_no_package',
- {date => $header{date},
- subject => $subject,
- messageid => $header{'message-id'},
- baddress => $baddress,
- },
- ),[join("\n", @msg)]), '',undef,1);
- &appendlog;
- &finish;
- }
-
- if (defined $config{default_package}) {
- &checkmaintainers;
- # if there are no maintainers for this package, assign it to the default package
- if (not @maintaddrs) {
- $data->{package} = $config{default_package};
- $brokenness.= fill_template('mail/process_default_package_selected',
- {old_package => $pheader{source} || $pheader{package} || 'No package',
- new_package => $data->{package},
- }
- );
- # force the maintainers to be rechecked
- $maintainerschecked = 0;
- &checkmaintainers;
- }
- }
-
- $data->{keywords}= '';
- if (defined($pheader{'keywords'})) {
- $data->{keywords}= $pheader{'keywords'};
- } elsif (defined($pheader{'tags'})) {
- $data->{keywords}= $pheader{'tags'};
- }
- if (length($data->{keywords})) {
- my @kws;
- my %gkws = map { ($_, 1) } @gTags;
- foreach my $kw (sort split(/[,\s]+/, lc($data->{keywords}))) {
- push @kws, $kw if (defined $gkws{$kw});
- }
- $data->{keywords} = join(" ", @kws);
- }
- $data->{severity}= '';
- if (defined($pheader{'severity'}) || defined($pheader{'priority'})) {
- $data->{severity}= $pheader{'severity'};
- $data->{severity}= $pheader{'priority'} unless ($data->{severity});
- $data->{severity} =~ s/^\s*(.+)\s*$/$1/;
-
- if (!grep($_ eq $data->{severity}, @gSeverityList, "$gDefaultSeverity")) {
- $brokenness.= fill_template('mail/invalid_severity',
- {severity=>$data->{severity}}
- );
- $data->{severity}= '';
- }
- }
- if (defined($pheader{owner})) {
- $data->{owner}= $pheader{owner};
- }
- if (defined($pheader{forwarded})) {
- $data->{'forwarded-to'} = $pheader{forwarded};
- }
- &filelock("nextnumber.lock");
- open(N,"nextnumber") || &quit("nextnumber: read: $!");
- my $nextnumber=<N>; $nextnumber =~ s/\n$// || &quit("nextnumber bad format");
- $ref= $nextnumber+0; $nextnumber += 1; $newref=1;
- &overwrite('nextnumber', "$nextnumber\n");
- &unfilelock;
- my $hash = get_hashname($ref);
- &overwrite("db-h/$hash/$ref.log",'');
- $data->{originator} = $replyto;
- $data->{date} = $intdate;
- $data->{subject} = $subject;
- $data->{msgid} = $header{'message-id'};
- writebug($ref, $data);
- # Deal with usertags
- if (exists $pheader{usertags}) {
- my $user = $replyto;
- $user = $pheader{user} if exists $pheader{user};
- $user =~ s/,.*//;
- $user =~ s/^.*<(.*)>.*$/$1/;
- $user =~ s/[(].*[)]//;
- $user =~ s/^\s*(\S+)\s+.*$/$1/;
- if ($user ne '' and Debbugs::User::is_valid_user($user)) {
- $pheader{usertags} =~ s/(?:^\s+|\s+$)//g;
- my %user_tags;
- read_usertags(\%user_tags,$user);
- for my $tag (split /[,\s]+/, $pheader{usertags}) {
- if ($tag =~ /^[a-zA-Z0-9.+\@-]+/) {
- my %bugs_with_tag;
- @bugs_with_tag{@{$user_tags{$tag}||[]}} = (1) x @{$user_tags{$tag}||[]};
- $bugs_with_tag{$ref} = 1;
- $user_tags{$tag} = [keys %bugs_with_tag];
- }
- }
- write_usertags(\%user_tags,$user);
- }
- else {
- $brokenness .= fill_template('mail/invalid_user',
- {user => $user}
- );
- }
- }
- &overwrite("db-h/$hash/$ref.report",
- join("\n",@msg)."\n");
-}
-
-&checkmaintainers;
-
-print DEBUG "maintainers >".join(' ',@maintaddrs)."<\n";
-
-my $orgsender= defined($header{'sender'}) ? "Original-Sender: $header{'sender'}\n" : '';
-my $newsubject= $subject; $newsubject =~ s/^$gBug#$ref:*\s*//;
-
-my $xcchdr= $header{ 'x-debbugs-cc' } || '';
-if ($xcchdr =~ m/\S/) {
- push(@resentccs,$xcchdr);
- $resentccexplain.= fill_template('mail/xdebbugscc',
- {xcchdr => $xcchdr},
- );
-}
-
-if (@maintaddrs && ($codeletter eq 'B' || $codeletter eq 'M')) {
- push(@resentccs,@maintaddrs);
- $resentccexplain.= fill_template('mail/maintainercc',
- {maintaddrs => \@maintaddrs,
- },
- );
-}
-
-@bccs = @addsrcaddrs;
-if (defined $gStrongList and isstrongseverity($data->{severity})) {
- push @bccs, "$gStrongList\@$gListDomain";
-}
-
-# Send mail to the per bug list subscription too
-push @bccs, "bugs=$ref\@$gListDomain";
-
-if (defined $pheader{source}) {
- # Prefix source versions with the name of the source package. They
- # appear that way in version trees so that we can deal with binary
- # packages moving from one source package to another.
- if (defined $pheader{'source-version'}) {
- if ($pheader{'source-version'} !~ m/^$config{package_version_re}$/) {
- $brokenness .= fill_template('mail/invalid_version',
- {version => $pheader{'source-version'}},
- );
- }
- else {
- addfoundversions($data, $pheader{source}, $pheader{'source-version'}, '');
- }
- } elsif (defined $pheader{version}) {
- if ($pheader{version} !~ m/^$config{package_version_re}$/) {
- $brokenness .= fill_template('mail/invalid_version',
- {version => $pheader{version}},
- );
- }
- else {
- addfoundversions($data, $pheader{source}, $pheader{version}, '');
- }
- }
- writebug($ref, $data);
-} elsif (defined $pheader{package}) {
- # TODO: could handle Source-Version: by looking up the source package?
- if (defined $pheader{version}) {
- if ($pheader{version} !~ m/^$config{package_version_re}$/) {
- $brokenness .= fill_template('mail/invalid_version',
- {version => $pheader{version}},
- );
- }
- else {
- addfoundversions($data, $pheader{package}, $pheader{version}, 'binary');
- }
- }
- writebug($ref, $data);
-}
-
-my $veryquiet= $codeletter eq 'Q';
-if ($codeletter eq 'M' && !@maintaddrs) {
- $veryquiet= 1;
- $brokenness.= fill_template('mail/invalid_maintainer',
- {},
- );
-}
-
-my $resentccval.= join(', ',@resentccs);
-$resentccval =~ s/\s+\n\s+/ /g; $resentccval =~ s/^\s+/ /; $resentccval =~ s/\s+$//;
-my $resentcc = '';
-if (length($resentccval)) {
- $resentcc= "Resent-CC: $resentccval\n";
-}
-
-if ($codeletter eq 'U') { # sent to -submitter
- &htmllog("Message", "sent on", $data->{originator}, "$gBug#$ref.");
- &sendmessage(<<END,[$data->{originator},@resentccs],[@bccs]);
-Subject: $gBug#$ref: $newsubject
-Reply-To: $replyto, $ref-quiet\@$gEmailDomain
-${orgsender}Resent-To: $data->{originator}
-${resentcc}Resent-Date: $tdate
-Resent-Message-ID: <handler.$ref.$nn\@$gEmailDomain>
-Resent-Sender: $gMaintainerEmail
-X-$gProject-PR-Message: report $ref
-X-$gProject-PR-Package: $data->{package}
-X-$gProject-PR-Keywords: $data->{keywords}
-${source_pr_header}$fwd
-END
-} elsif ($codeletter eq 'B') { # Sent to submit
- my $report_followup = $newref ? 'report' : 'followup';
- &htmllog($newref ? "Report" : "Information", "forwarded",
- join(', ',"$gSubmitList\@$gListDomain",@resentccs),
- "<code>$gBug#$ref</code>".
- (length($data->{package})? "; Package <code>".html_escape($data->{package})."</code>" : '').
- ".");
- &sendmessage(<<END,["$gSubmitList\@$gListDomain",@resentccs],[@bccs]);
-Subject: $gBug#$ref: $newsubject
-Reply-To: $replyto, $ref\@$gEmailDomain
-Resent-From: $header{'from'}
-${orgsender}Resent-To: $gSubmitList\@$gListDomain
-${resentcc}Resent-Date: $tdate
-Resent-Message-ID: <handler.$ref.$nn\@$gEmailDomain>
-Resent-Sender: $gMaintainerEmail
-X-$gProject-PR-Message: $report_followup $ref
-X-$gProject-PR-Package: $data->{package}
-X-$gProject-PR-Keywords: $data->{keywords}
-${source_pr_header}$fwd
-END
-} elsif (@resentccs or @bccs) { # Quiet or Maintainer
- # D and F done far earlier; B just done - so this must be M or Q
- # We preserve whichever it was in the Reply-To (possibly adding
- # the $gBug#).
- my $report_followup = $newref ? 'report' : 'followup';
- if (@resentccs) {
- &htmllog($newref ? "Report" : "Information", "forwarded",
- $resentccval,
- "<code>$gBug#$ref</code>".
- (length($data->{package}) ? "; Package <code>".html_escape($data->{package})."</code>" : '').
- ".");
- } else {
- &htmllog($newref ? "Report" : "Information", "stored",
- "",
- "<code>$gBug#$ref</code>".
- (length($data->{package}) ? "; Package <code>".html_escape($data->{package})."</code>" : '').
- ".");
- }
- &sendmessage(<<END,[@resentccs],[@bccs]);
-Subject: $gBug#$ref: $newsubject
-Reply-To: $replyto, $ref-$baddressroot\@$gEmailDomain
-Resent-From: $header{'from'}
-${orgsender}Resent-To: $resentccval
-Resent-Date: $tdate
-Resent-Message-ID: <handler.$ref.$nn\@$gEmailDomain>
-Resent-Sender: $gMaintainerEmail
-X-$gProject-PR-Message: $report_followup $ref
-X-$gProject-PR-Package: $data->{package}
-X-$gProject-PR-Keywords: $data->{keywords}
-${source_pr_header}$fwd
-END
-}
-
-my $htmlbreak= length($brokenness) ? "<p>\n".html_escape($brokenness)."\n<p>\n" : '';
-$htmlbreak =~ s/\n\n/\n<P>\n\n/g;
-if (length($resentccval)) {
- $htmlbreak = " Copy sent to <code>".html_escape($resentccval)."</code>.".
- $htmlbreak;
-}
-
-# Should we send an ack out?
-if (not exists $header{'x-debbugs-no-ack'} and
- ($newref or
- ($codeletter ne 'U' and
- (not defined $header{precedence} or
- $header{'precedence'} !~ /\b(?:bulk|junk|list)\b/
- )
- )
- )
- ){
-
- # figure out forward explanation
- my $forwardexplain = '';
- my $thanks = '';
- my $extra_vars;
- # will contain info and -info in moreinfo messages
- my $info = '';
- my $infod = '';
- # temporary headers
- my %t_h;
- if ($newref) {
- &htmllog("Acknowledgement","sent",$replyto,
- ($veryquiet ?
- "New $gBug report received and filed, but not forwarded." :
- "New $gBug report received and forwarded."). $htmlbreak);
- $thanks = fill_template('mail/process_ack_thanks_new');
- }
- else {
- &htmllog("Acknowledgement","sent",$replyto,
- ($veryquiet ? "Extra info received and filed, but not forwarded." :
- $codeletter eq 'M' ? "Extra info received and forwarded to maintainer." :
- "Extra info received and forwarded to list."). $htmlbreak);
- $thanks = fill_template('mail/process_ack_thanks_additional');
- $info = 'info';
- $infod = '-info';
- }
- if ($veryquiet) {
- $forwardexplain = fill_template('mail/forward_veryquiet',
- );
- # these are the headers that quiet messages override
- $t_h{messageid} = "<handler.$ref.$nn.ack${info}quiet\@$gEmailDomain>";
- $t_h{pr_message} = "ack${infod}-quiet $ref";
- $t_h{reply_to} = "$ref-quiet\@$gEmailDomain";
- $extra_vars->{refreplyto} = "$ref-quiet\@$gEmailDomain";
- $t_h{subject} = length($info)?
- "$gBug#$ref: Info received and FILED only ($subject)":
- "$gBug#$ref: Acknowledgement of QUIET report ($subject)";
- }
- elsif ($codeletter eq 'M') {
- $forwardexplain = fill_template('mail/forward_maintonly',
- );
- # these are the headers that maintonly messages override
- $t_h{messageid} = "<handler.$ref.$nn.ack{$info}maintonly\@$gEmailDomain>";
- $t_h{pr_message} = "ack${infod}-maintonly $ref";
- $t_h{reply_to} = "$ref-maintonly\@$gEmailDomain";
- $extra_vars->{refreplyto} = "$ref-maintonly\@$gEmailDomain";
- $t_h{subject} = length($info)?
- "$gBug#$ref: Info received for maintainer only ($subject)":
- "$gBug#$ref: Acknowledgement of maintainer-only report ($subject)";
- }
- else {
- $forwardexplain = fill_template('mail/forward_normal',
- );
- $t_h{messageid} = "<handler.$ref.$nn.ack${info}\@$gEmailDomain>";
- $t_h{pr_message} = "ack${infod} $ref";
- $t_h{reply_to} = "$ref\@$gEmailDomain";
- $extra_vars->{refreplyto} = "$ref\@$gEmailDomain";
- $t_h{subject} = (defined $info and length($info))?
- "$gBug#$ref: Info received ($subject)" :
- "$gBug#$ref: Acknowledgement ($subject)";
- }
- my $body = message_body_template('mail/process_ack',
- {forwardexplain => $forwardexplain,
- resentccexplain => $resentccexplain,
- thanks => $thanks,
- %{$extra_vars}
- }
- );
- &sendmessage(create_mime_message(
- ["X-Loop" => "$gMaintainerEmail",
- From => "$gMaintainerEmail ($gProject $gBug Tracking System)",
- To => $replyto,
- Subject => $t_h{subject},
- "Message-ID" => $t_h{messageid},
- "In-Reply-To" => $header{'message-id'},
- References => $header{'message-id'},
- Precedence => 'bulk',
- "X-$gProject-PR-Message" => $t_h{pr_message} || "ack $ref",
- "X-$gProject-PR-Package" => $data->{package},
- "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" => $t_h{reply_to} || "$ref\@$gEmailDomain",
- ],$body,[]), '',undef,1);
-}
-
-&appendlog;
-&finish;
-
-sub overwrite {
- my ($f,$v) = @_;
- open(NEW,">$f.new") || &quit("$f.new: create: $!");
- print(NEW "$v") || &quit("$f.new: write: $!");
- close(NEW) || &quit("$f.new: close: $!");
- rename("$f.new","$f") || &quit("rename $f.new to $f: $!");
-}
-
-sub appendlog {
- my $hash = get_hashname($ref);
- if (!open(AP,">>db-h/$hash/$ref.log")) {
- print DEBUG "failed open log<\n";
- print DEBUG "failed open log err $!<\n";
- &quit("opening db-h/$hash/$ref.log (li): $!");
- }
- print(AP "\7\n",escape_log(@log),"\n\3\n") || &quit("writing db-h/$hash/$ref.log (li): $!");
- close(AP) || &quit("closing db-h/$hash/$ref.log (li): $!");
-}
-
-sub finish {
- my ($exit) = @_;
- $exit ||= 0;
- utime(time,time,"db");
- # cleanups are run in an end block now.
- #my ($u);
- #while ($u= $cleanups[$#cleanups]) { &$u; }
- unlink("incoming/P$nn") || &quit("unlinking incoming/P$nn: $!");
- exit $exit;
-}
-
-&quit("wot no exit");
-
-sub htmllog {
- my ($whatobj,$whatverb,$where,$desc) = @_;
- my $hash = get_hashname($ref);
- open(AP,">>db-h/$hash/$ref.log") || &quit("opening db-h/$hash/$ref.log (lh): $!");
- print(AP
- "\6\n".
- "<strong>$whatobj $whatverb</strong>".
- ($where eq '' ? "" : " to <code>".html_escape($where)."</code>").
- ":<br>\n". $desc.
- "\n\3\n") || &quit("writing db-h/$hash/$ref.log (lh): $!");
- close(AP) || &quit("closing db-h/$hash/$ref.log (lh): $!");
-}
-
-sub stripbccs {
- my $msg = shift;
- my $ret = '';
- my $bcc = 0;
- while ($msg =~ s/(.*\n)//) {
- local $_ = $1;
- if (/^$/) {
- $ret .= $_;
- last;
- }
- if ($bcc) {
- # strip continuation lines too
- next if /^\s/;
- $bcc = 0;
- }
- if (/^Bcc:/i) {
- $bcc = 1;
- } else {
- $ret .= $_;
- }
- }
- return $ret . $msg;
-}
-
-=head2 send_message
-
- send_message($the_message,\@recipients,\@bcc,$do_not_encode)
-
-The first argument is the scalar message, the second argument is the
-arrayref of recipients, the third is the arrayref of Bcc:'ed
-recipients.
-
-The final argument turns off header encoding and the addition of the
-X-Loop header if true, defaults to false.
-
-=cut
-
-
-sub sendmessage {
- my ($msg,$recips,$bcc,$no_encode) = @_;
- if (not defined $recips or (!ref($recips) && $recips eq '')
- or @$recips == 0) {
- $recips = ['-t'];
- }
- # This is suboptimal. The right solution is to send headers
- # separately from the rest of the message and encode them rather
- # than doing this.
- $msg = "X-Loop: $gMaintainerEmail\n" . $msg unless $no_encode;
- # The original message received is written out in appendlog, so
- # before writing out the other messages we've sent out, we need to
- # RFC1522 encode the header.
- $msg = encode_headers($msg) unless $no_encode;
-
- my $hash = get_hashname($ref);
- #save email to the log
- open(AP,">>db-h/$hash/$ref.log") || &quit("opening db-h/$hash/$ref.log (lo): $!");
- print(AP "\2\n",join("\4",@$recips),"\n\5\n",
- escape_log(stripbccs($msg)),"\n\3\n") ||
- &quit("writing db-h/$hash/$ref.log (lo): $!");
- close(AP) || &quit("closing db-h/$hash/$ref.log (lo): $!");
-
- if (ref($bcc)) {
- shift @$recips if $recips->[0] eq '-t';
- push @$recips, @$bcc;
- }
-
- send_mail_message(message => $msg,
- # Because we encode the headers above, we do not want to encode them here
- encode_headers => 0,
- recipients => $recips);
-}
-
-=head2 message_body_template
-
- message_body_template('mail/ack',{ref=>'foo'});
-
-Creates a message body using a template
-
-=cut
-
-sub message_body_template{
- my ($template,$extra_var) = @_;
- $extra_var ||={};
- my $body = fill_template($template,$extra_var);
- return fill_template('mail/message_body',
- {%{$extra_var},
- body => $body,
- },
- );
-}
-
-=head2 fill_template
-
- fill_template('mail/foo',{foo=>'bar'});
-
-Calls fill_in_template with a default set of variables and any extras
-added in.
-
-=cut
-
-sub fill_template{
- my ($template,$extra_var) = @_;
- $extra_var ||={};
- my $variables = {config => \%config,
- defined($ref)?(ref => $ref):(),
- defined($data)?(data => $data):(),
- %{$extra_var},
- };
- my $hole_var = {'&bugurl' =>
- sub{"$_[0]: ".
- 'http://'.$config{cgi_domain}.'/'.
- Debbugs::CGI::bug_url($_[0]);
- }
- };
- return fill_in_template(template => $template,
- variables => $variables,
- hole_var => $hole_var,
- );
-}
-
-
-sub checkmaintainers {
- return if $maintainerschecked++;
- return if !length($data->{package});
- my %maintainerof;
- open(MAINT,"$gMaintainerFile") || die &quit("maintainers open: $!");
- while (<MAINT>) {
- m/^\n$/ && next;
- m/^\s*$/ && next;
- m/^(\S+)\s+(\S.*\S)\s*\n$/ || &quit("maintainers bogus \`$_'");
- $a= $1; $b= $2; $a =~ y/A-Z/a-z/;
- # use the package which is normalized to lower case; we do this because we lc the pseudo headers.
- $maintainerof{$a}= $2;
- }
- close(MAINT);
- open(MAINT,"$gMaintainerFileOverride") || die &quit("maintainers.override open: $!");
- while (<MAINT>) {
- m/^\n$/ && next;
- m/^\s*$/ && next;
- m/^(\S+)\s+(\S.*\S)\s*\n$/ || &quit("maintainers.override bogus \`$_'");
- $a= $1; $b= $2; $a =~ y/A-Z/a-z/;
- # use the package which is normalized to lower case; we do this because we lc the pseudo headers.
- $maintainerof{$a}= $2;
- }
- close(MAINT);
- my %pkgsrc;
- open(SOURCES,"$gPackageSource") || &quit("pkgsrc open: $!");
- while (<SOURCES>) {
- next unless m/^(\S+)\s+\S+\s+(\S.*\S)\s*$/;
- ($a,$b)=($1,$2);
- $a =~ y/A-Z/a-z/;
- $pkgsrc{$a} = $b;
- }
- close(SOURCES);
- my $anymaintfound=0; my $anymaintnotfound=0;
- for my $p (split(m/[ \t?,():]+/,$data->{package})) {
- $p =~ y/A-Z/a-z/;
- $p =~ /([a-z0-9.+-]+)/;
- $p = $1;
- next unless defined $p;
- if (defined $gSubscriptionDomain) {
- if (defined($pkgsrc{$p})) {
- push @addsrcaddrs, "$pkgsrc{$p}\@$gSubscriptionDomain";
- } else {
- push @addsrcaddrs, "$p\@$gSubscriptionDomain";
- }
- }
- if (defined($maintainerof{$p})) {
- print DEBUG "maintainer add >$p|$maintainerof{$p}<\n";
- my $addmaint= $maintainerof{$p};
- push(@maintaddrs,$addmaint) unless
- $addmaint eq $replyto || grep($_ eq $addmaint, @maintaddrs);
- $anymaintfound++;
- } else {
- print DEBUG "maintainer none >$p<\n";
- push(@maintaddrs,$gUnknownMaintainerEmail) unless $anymaintnotfound;
- $anymaintnotfound++;
- last;
- }
- }
-
- if (defined $data->{owner} and length $data->{owner}) {
- print DEBUG "owner add >$data->{package}|$data->{owner}<\n";
- my $addmaint = $data->{owner};
- push(@maintaddrs, $addmaint) unless
- $addmaint eq $replyto or grep($_ eq $addmaint, @maintaddrs);
- }
-}
-
-=head2 bug_list_forward
-
- bug_list_forward($spool_filename) if $codeletter eq 'L';
-
-
-Given the spool file, will forward a bug to the per bug mailing list
-subscription system.
-
-=cut
-
-sub bug_list_forward{
- my ($bug_fn) = @_;
- # Read the bug information and package information for passing to
- # the mailing list
- my ($bug_number) = $bug_fn =~ /^L(\d+)\./;
- my ($bfound, $data)= lockreadbugmerge($bug_number);
- my $bug_fh = IO::File->new("incoming/P$bug_fn",'r') or die "Unable to open incoming/P$bug_fn $!";
-
- local $/ = undef;
- my $bug_message = <$bug_fh>;
- my ($bug_address) = $bug_message =~ /^Received: \(at ([^\)]+)\) by/;
- my ($envelope_from) = $bug_message =~ s/\nFrom\s+([^\s]+)[^\n]+\n/\n/;
- if (not defined $envelope_from) {
- # Try to use the From: header or something to set it
- ($envelope_from) = $bug_message =~ /\nFrom:\s+(.+?)\n/;
- # Kludgy, and should really be using a full scale header
- # parser to do this.
- $envelope_from =~ s/^.+?<([^>]+)>.+$/$1/;
- }
- my ($header,$body) = split /\n\n/, $bug_message, 2;
- # Add X-$gProject-PR-Message: list bug_number, package name, and bug title headers
- $header .= qq(\nX-$gProject-PR-Message: list $bug_number\n).
- qq(X-$gProject-PR-Package: $data->{package}\n).
- qq(X-$gProject-PR-Title: $data->{subject})
- if defined $data;
- print STDERR "Tried to loop me with $envelope_from\n"
- and exit 1 if $envelope_from =~ /\Q$gListDomain\E|\Q$gEmailDomain\E/;
- print DEBUG $envelope_from,qq(\n);
- # If we don't have a bug address, something has gone horribly wrong.
- print STDERR "Doesn't match: $bug_address\n" and exit 1 unless defined $bug_address;
- $bug_address =~ s/\@.+//;
- print DEBUG "Sending message to bugs=$bug_address\@$gListDomain\n";
- print DEBUG $header.qq(\n\n).$body;
- send_mail_message(message => $header.qq(\n\n).$body,
- recipients => ["bugs=$bug_address\@$gListDomain"],
- envelope_from => $envelope_from,
- encode_headers => 0,
- );
- unlink("incoming/P$bug_fn") || &quit("unlinking incoming/P$bug_fn: $!");
- exit 0;
-}
--- /dev/null
+#!/usr/bin/perl
+# $Id: processall.in,v 1.13 2005/10/06 03:46:13 ajt Exp $
+#
+# Usage: processall
+#
+# Uses up: incoming/I<code><bugnum>.nn
+# Temps: incoming/[GP].nn
+# Creates: incoming/E.nn
+# Stop: stop
+
+use warnings;
+use strict;
+
+
+use Debbugs::Config qw(:globals);
+use Debbugs::Common qw(:lock);
+
+my $lib_path = $gLibPath;
+
+use File::Path;
+
+chdir( $gSpoolDir ) || die "chdir spool: $!\n";
+
+#open(DEBUG,">&4");
+
+umask(002);
+
+$|=1;
+my %fudged;
+my @ids;
+
+my $ndone = 0;
+&filelock('incoming-cleaner');
+for (;;) {
+ if (-f 'stop') {
+ print(STDERR "stop file created\n") || die $!;
+ last;
+ }
+ if (!@ids) {
+ opendir(DIR,"incoming") || die $!;
+ while ( defined( $_= readdir(DIR) )) { push(@ids,$_) if s/^I//; }
+ last unless @ids;
+ @ids= sort(@ids);
+ }
+ stat("$gMaintainerFile") || die "stat $gMaintainerFile: $!\n";
+ my $nf= @ids;
+ my $id= shift(@ids);
+ unless (rename("incoming/I$id","incoming/G$id")) {
+ if ($fudged{$id}) {
+ die "$id already fudged once! $!\n";
+ }
+ $fudged{$id}= 1;
+ next;
+ }
+ my $c;
+ if ($id =~ m/^[RC]/) {
+ print(STDOUT "[$nf] $id service ...") || die $!;
+ defined($c=fork) || die $!;
+ if (!$c) { exec("$lib_path/service",$id); die "unable to execute $lib_path/service: $!"; }
+ } elsif ($id =~ m/^[BMQFDUL]/) {
+ print(STDOUT "[$nf] $id process ...") || die $!;
+ defined($c=fork) || die $!;
+ if (!$c) { exec("$lib_path/process",$id); die "unable to execute $lib_path/process: $!"; }
+ } else {
+ die "bad name $id";
+ }
+ my $cc=waitpid($c,0); $cc == $c || die "$cc $c $!";
+ my $status=$?;
+ if ($status) {
+ print(STDERR "$id: process failed ($status $!) - now in [PG]$id\n") || die $!;
+ }
+ print(STDOUT " done\n") || die $!;
+ rmtree("$gSpoolDir/mime.tmp",0,1);
+ $ndone++;
+}
+
+
+system("$lib_path/gen-indices",'--quick') == 0 or print STDERR "gen-indices failed\n";
+
+if (@gPostProcessall) {
+ system @gPostProcessall == 0 or print STDERR "\@gPostProcessall failed: ".join(' ',@gPostProcessall)."\n";
+}
+
+
+
+&unfilelock;
+
+exit(0);
+++ /dev/null
-#!/usr/bin/perl
-# $Id: processall.in,v 1.13 2005/10/06 03:46:13 ajt Exp $
-#
-# Usage: processall
-#
-# Uses up: incoming/I<code><bugnum>.nn
-# Temps: incoming/[GP].nn
-# Creates: incoming/E.nn
-# Stop: stop
-
-use warnings;
-use strict;
-
-
-use Debbugs::Config qw(:globals);
-use Debbugs::Common qw(:lock);
-
-my $lib_path = $gLibPath;
-
-use File::Path;
-
-chdir( $gSpoolDir ) || die "chdir spool: $!\n";
-
-#open(DEBUG,">&4");
-
-umask(002);
-
-$|=1;
-my %fudged;
-my @ids;
-
-my $ndone = 0;
-&filelock('incoming-cleaner');
-for (;;) {
- if (-f 'stop') {
- print(STDERR "stop file created\n") || die $!;
- last;
- }
- if (!@ids) {
- opendir(DIR,"incoming") || die $!;
- while ( defined( $_= readdir(DIR) )) { push(@ids,$_) if s/^I//; }
- last unless @ids;
- @ids= sort(@ids);
- }
- stat("$gMaintainerFile") || die "stat $gMaintainerFile: $!\n";
- my $nf= @ids;
- my $id= shift(@ids);
- unless (rename("incoming/I$id","incoming/G$id")) {
- if ($fudged{$id}) {
- die "$id already fudged once! $!\n";
- }
- $fudged{$id}= 1;
- next;
- }
- my $c;
- if ($id =~ m/^[RC]/) {
- print(STDOUT "[$nf] $id service ...") || die $!;
- defined($c=fork) || die $!;
- if (!$c) { exec("$lib_path/service",$id); die "unable to execute $lib_path/service: $!"; }
- } elsif ($id =~ m/^[BMQFDUL]/) {
- print(STDOUT "[$nf] $id process ...") || die $!;
- defined($c=fork) || die $!;
- if (!$c) { exec("$lib_path/process",$id); die "unable to execute $lib_path/process: $!"; }
- } else {
- die "bad name $id";
- }
- my $cc=waitpid($c,0); $cc == $c || die "$cc $c $!";
- my $status=$?;
- if ($status) {
- print(STDERR "$id: process failed ($status $!) - now in [PG]$id\n") || die $!;
- }
- print(STDOUT " done\n") || die $!;
- rmtree("$gSpoolDir/mime.tmp",0,1);
- $ndone++;
-}
-
-
-system("$lib_path/gen-indices",'--quick') == 0 or print STDERR "gen-indices failed\n";
-
-if (@gPostProcessall) {
- system @gPostProcessall == 0 or print STDERR "\@gPostProcessall failed: ".join(' ',@gPostProcessall)."\n";
-}
-
-
-
-&unfilelock;
-
-exit(0);
--- /dev/null
+#!/usr/bin/perl -w
+# $Id: rebuild.in,v 1.13 2003/08/23 15:12:57 cjwatson Exp $
+
+# Load modules and set environment
+use File::Copy;
+$config_path = '/etc/debbugs';
+$lib_path = '/usr/lib/debbugs';
+
+require("$config_path/config");
+require("$lib_path/errorlib");
+use vars qw($gSpoolDir);
+
+$ENV{'PATH'} = $lib_path.':'.$ENV{'PATH'};
+
+chdir("$gSpoolDir") || die "chdir spool: $!\n";
+
+#global variables
+$debug = 0;
+
+@ARGV==0 and die "no archive given on the commandline" ;
+my $archive = shift(@ARGV);
+my $index = "index.$archive";
+$index = 'index.db' if $archive eq 'db-h';
+open IDXFILE, "> $index" or die "trying to reset index file: $!" ;
+
+#get list of bugs (ie, status files)
+my @files;
+for ($subdir=0; $subdir<100; $subdir++ )
+{
+ my $path = sprintf( "$archive/%.2d", $subdir );
+ opendir(DIR,$path) || next;
+ my @list= grep(m/^\d+\.summary$/,readdir(DIR));
+ closedir DIR;
+ grep(s/\.summary$//,@list);
+ push @files, @list;
+}
+
+@files = sort { $a <=> $b } @files;
+
+#process each bug (ie, status file)
+for my $ref (@files)
+{
+ print STDERR "$ref considering\n" if $debug;
+ my $data = readbug($ref, $archive);
+ $data->{severity} =~ y/A-Z/a-z/;
+
+ (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g;
+ $pkglist =~ s/^,+//;
+ $pkglist =~ s/,+$//;
+
+ my $whendone = 'open';
+ $whendone = 'forwarded' if length $data->{forwarded};
+ $whendone = 'done' if length $data->{done};
+
+ printf IDXFILE "%s %d %d %s [%s] %s %s\n",
+ $pkglist, $ref, $data->{date}, $whendone, $data->{originator},
+ $data->{severity}, $data->{keywords};
+}
+
+close IDXFILE;
+++ /dev/null
-#!/usr/bin/perl -w
-# $Id: rebuild.in,v 1.13 2003/08/23 15:12:57 cjwatson Exp $
-
-# Load modules and set environment
-use File::Copy;
-$config_path = '/etc/debbugs';
-$lib_path = '/usr/lib/debbugs';
-
-require("$config_path/config");
-require("$lib_path/errorlib");
-use vars qw($gSpoolDir);
-
-$ENV{'PATH'} = $lib_path.':'.$ENV{'PATH'};
-
-chdir("$gSpoolDir") || die "chdir spool: $!\n";
-
-#global variables
-$debug = 0;
-
-@ARGV==0 and &quit( "no archive given on the commandline" );
-my $archive = shift(@ARGV);
-my $index = "index.$archive";
-$index = 'index.db' if $archive eq 'db-h';
-open IDXFILE, "> $index" or &quit( "trying to reset index file: $!" );
-
-#get list of bugs (ie, status files)
-my @files;
-for ($subdir=0; $subdir<100; $subdir++ )
-{
- my $path = sprintf( "$archive/%.2d", $subdir );
- opendir(DIR,$path) || next;
- my @list= grep(m/^\d+\.summary$/,readdir(DIR));
- closedir DIR;
- grep(s/\.summary$//,@list);
- push @files, @list;
-}
-
-@files = sort { $a <=> $b } @files;
-
-#process each bug (ie, status file)
-for my $ref (@files)
-{
- print STDERR "$ref considering\n" if $debug;
- my $data = readbug($ref, $archive);
- $data->{severity} =~ y/A-Z/a-z/;
-
- (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g;
- $pkglist =~ s/^,+//;
- $pkglist =~ s/,+$//;
-
- my $whendone = 'open';
- $whendone = 'forwarded' if length $data->{forwarded};
- $whendone = 'done' if length $data->{done};
-
- printf IDXFILE "%s %d %d %s [%s] %s %s\n",
- $pkglist, $ref, $data->{date}, $whendone, $data->{originator},
- $data->{severity}, $data->{keywords};
-}
-
-close IDXFILE;
--- /dev/null
+#!/usr/bin/perl
+# $Id: receive.in,v 1.17 2005/07/24 18:42:41 don Exp $
+# usage: mail is piped directly into program
+
+#set umask in order to have group-writable incoming/*
+#umask(002);
+
+use Debbugs::Config qw(:globals :text);
+my $lib_path = $gLibPath;
+
+$ENV{'PATH'} = '/usr/lib/debbugs:'.$ENV{'PATH'};
+
+#set source of mail delivery
+#sets any prefix needed to get mailer to add it to error mail
+if ( $gMailer eq 'exim' )
+{ $gBadEmailPrefix = '';
+ $_ = $ENV{'LOCAL_PART'};
+} elsif ( $gMailer eq 'qmail' )
+{ $gBadEmailPrefix = '//';
+ $_ = $ENV{'DEFAULT'};
+# $_ = $ENV{'RECIPIENT'};
+# s/^\w+-bugs--?//;
+} else
+{ $gBadEmailPrefix = '';
+ $_ = $ARGV[0];
+ s/\>//;
+ s/\<//;
+}
+
+#remove everything from @ to end of line
+s/\@.*$//;
+
+#convert remaining upper case to lower case
+y/A-Z/a-z/;
+
+#set up to determine command
+%withbugaddressmap= ('-submit', 'B',
+ '', 'B',
+ '-maintonly', 'M',
+ '-quiet', 'Q',
+ '-forwarded', 'F',
+ '-done', 'D',
+ '-close', 'D',
+ '-request', 'R',
+ '-submitter', 'U',
+ # Used for bug subscription
+ #'-list-nothing-will-match-this', 'L',
+ );
+
+%withpkgaddressmap= ('-request', 'R');
+
+%withoutaddressmap= ('submit', 'B',
+ 'bugs', 'B',
+ 'maintonly', 'M',
+ 'quiet', 'Q',
+ 'forwarded', 'F',
+ 'done', 'D',
+ 'close', 'D',
+ 'request', 'R',
+ 'submitter', 'U',
+ 'control', 'C');
+
+#determine command
+if (s/^(\d{1,9})\b//) {
+ $bugnumber= $1;
+ if (not exists $withbugaddressmap{$_} and
+/-(?:(?:un)?subscribe|subhelp|help|ignore|(?:sub(?:yes|approve|reject)
+ |unsubyes|bounce|probe|approve|reject|
+ setlistyes|setlistsilentyes).*)/x
+ ) {
+ $map = 'L';
+ }
+ else {
+ $map= $withbugaddressmap{$_};
+ }
+ $addrrec= "$bugnumber$_";
+} elsif (s/^(\w+)-//) {
+ $bugnumber= $1;
+ $map= $withpkgaddressmap{"-$_"};
+ $addrrec= "$bugnumber-$_";
+} else {
+ $bugnumber= '';
+ $map= $withoutaddressmap{$_};
+ $addrrec= "$_";
+}
+
+#print no command received
+if (!defined($map)) {
+ print STDERR <<ENDTEXT;
+$gBadEmailPrefix
+$gBadEmailPrefix Unknown $gBug service address $_\@$gEmailDomain.
+$gBadEmailPrefix Recognised addresses are:
+$gBadEmailPrefix
+$gBadEmailPrefix General: Read $gBug# in Subject: $gBug# is NNNN:
+$gBadEmailPrefix
+$gBadEmailPrefix request submit $gBug NNNN NNNN-submit
+$gBadEmailPrefix control maintonly NNNN-maintonly
+$gBadEmailPrefix owner quiet NNNN-quiet
+$gBadEmailPrefix postmaster forwarded NNNN-forwarded
+$gBadEmailPrefix done close NNNN-done NNNN-close
+$gBadEmailPrefix submitter NNNN-submitter
+$gBadEmailPrefix
+$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
+$gTextInstructions
+$gBadEmailPrefix For details of how to access $gBug report logs by email:
+$gBadEmailPrefix send \`request\@$gEmailDomain' the word \`help'
+$gBadEmailPrefix
+ENDTEXT
+ exit(100);
+}
+
+@months=qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
+($sec,$min,$hour,$mday,$mon,$year)= gmtime(time);
+
+$queue= "$map$bugnumber";
+
+chdir("$gSpoolDir/incoming") || &failure("chdir to spool: $!");
+
+$id= time.$$;
+open(FILE,">T.$id") || &failure("open temporary file: $!");
+printf(FILE "Received: (at %s) by $gEmailDomain; %d %s %d %02d:%02d:%02d +0000\n",
+ $addrrec, $mday,$months[$mon],$year+1900, $hour,$min,$sec) ||
+ &failure("write header to temporary file: $!");
+while(<STDIN>) { print(FILE) || &failure("write temporary file: $!"); }
+close(FILE) || &failure("close temporary file: $!");
+
+my $prefix;
+if ($gSpamScan) {
+ $prefix = 'S';
+} else {
+ $prefix = 'I';
+}
+rename("T.$id","$prefix$queue.$id") || &failure("rename spool message: $!");
+
+exit(0);
+
+sub failure {
+ length($id) && unlink("T.$id");
+ print STDERR "bugs receive failure: @_\n";
+ exit(75); # EX_TEMPFAIL
+}
+++ /dev/null
-#!/usr/bin/perl
-# $Id: receive.in,v 1.17 2005/07/24 18:42:41 don Exp $
-# usage: mail is piped directly into program
-
-#set umask in order to have group-writable incoming/*
-#umask(002);
-
-use Debbugs::Config qw(:globals :text);
-my $lib_path = $gLibPath;
-
-$ENV{'PATH'} = '/usr/lib/debbugs:'.$ENV{'PATH'};
-
-#set source of mail delivery
-#sets any prefix needed to get mailer to add it to error mail
-if ( $gMailer eq 'exim' )
-{ $gBadEmailPrefix = '';
- $_ = $ENV{'LOCAL_PART'};
-} elsif ( $gMailer eq 'qmail' )
-{ $gBadEmailPrefix = '//';
- $_ = $ENV{'DEFAULT'};
-# $_ = $ENV{'RECIPIENT'};
-# s/^\w+-bugs--?//;
-} else
-{ $gBadEmailPrefix = '';
- $_ = $ARGV[0];
- s/\>//;
- s/\<//;
-}
-
-#remove everything from @ to end of line
-s/\@.*$//;
-
-#convert remaining upper case to lower case
-y/A-Z/a-z/;
-
-#set up to determine command
-%withbugaddressmap= ('-submit', 'B',
- '', 'B',
- '-maintonly', 'M',
- '-quiet', 'Q',
- '-forwarded', 'F',
- '-done', 'D',
- '-close', 'D',
- '-request', 'R',
- '-submitter', 'U',
- # Used for bug subscription
- #'-list-nothing-will-match-this', 'L',
- );
-
-%withpkgaddressmap= ('-request', 'R');
-
-%withoutaddressmap= ('submit', 'B',
- 'bugs', 'B',
- 'maintonly', 'M',
- 'quiet', 'Q',
- 'forwarded', 'F',
- 'done', 'D',
- 'close', 'D',
- 'request', 'R',
- 'submitter', 'U',
- 'control', 'C');
-
-#determine command
-if (s/^(\d{1,9})\b//) {
- $bugnumber= $1;
- if (not exists $withbugaddressmap{$_} and
-/-(?:(?:un)?subscribe|subhelp|help|ignore|(?:sub(?:yes|approve|reject)
- |unsubyes|bounce|probe|approve|reject|
- setlistyes|setlistsilentyes).*)/x
- ) {
- $map = 'L';
- }
- else {
- $map= $withbugaddressmap{$_};
- }
- $addrrec= "$bugnumber$_";
-} elsif (s/^(\w+)-//) {
- $bugnumber= $1;
- $map= $withpkgaddressmap{"-$_"};
- $addrrec= "$bugnumber-$_";
-} else {
- $bugnumber= '';
- $map= $withoutaddressmap{$_};
- $addrrec= "$_";
-}
-
-#print no command received
-if (!defined($map)) {
- print STDERR <<ENDTEXT;
-$gBadEmailPrefix
-$gBadEmailPrefix Unknown $gBug service address $_\@$gEmailDomain.
-$gBadEmailPrefix Recognised addresses are:
-$gBadEmailPrefix
-$gBadEmailPrefix General: Read $gBug# in Subject: $gBug# is NNNN:
-$gBadEmailPrefix
-$gBadEmailPrefix request submit $gBug NNNN NNNN-submit
-$gBadEmailPrefix control maintonly NNNN-maintonly
-$gBadEmailPrefix owner quiet NNNN-quiet
-$gBadEmailPrefix postmaster forwarded NNNN-forwarded
-$gBadEmailPrefix done close NNNN-done NNNN-close
-$gBadEmailPrefix submitter NNNN-submitter
-$gBadEmailPrefix
-$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
-$gTextInstructions
-$gBadEmailPrefix For details of how to access $gBug report logs by email:
-$gBadEmailPrefix send \`request\@$gEmailDomain' the word \`help'
-$gBadEmailPrefix
-ENDTEXT
- exit(100);
-}
-
-@months=qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
-($sec,$min,$hour,$mday,$mon,$year)= gmtime(time);
-
-$queue= "$map$bugnumber";
-
-chdir("$gSpoolDir/incoming") || &failure("chdir to spool: $!");
-
-$id= time.$$;
-open(FILE,">T.$id") || &failure("open temporary file: $!");
-printf(FILE "Received: (at %s) by $gEmailDomain; %d %s %d %02d:%02d:%02d +0000\n",
- $addrrec, $mday,$months[$mon],$year+1900, $hour,$min,$sec) ||
- &failure("write header to temporary file: $!");
-while(<STDIN>) { print(FILE) || &failure("write temporary file: $!"); }
-close(FILE) || &failure("close temporary file: $!");
-
-my $prefix;
-if ($gSpamScan) {
- $prefix = 'S';
-} else {
- $prefix = 'I';
-}
-rename("T.$id","$prefix$queue.$id") || &failure("rename spool message: $!");
-
-exit(0);
-
-sub failure {
- length($id) && unlink("T.$id");
- print STDERR "bugs receive failure: @_\n";
- exit(75); # EX_TEMPFAIL
-}
--- /dev/null
+#!/usr/bin/perl
+# $Id: service.in,v 1.118 2005/10/19 01:22:14 don Exp $
+#
+# Usage: service <code>.nn
+# Temps: incoming/P<code>.nn
+
+use warnings;
+use strict;
+
+
+use Debbugs::Config qw(:globals :config);
+
+use File::Copy;
+use MIME::Parser;
+
+use Params::Validate qw(:types validate_with);
+
+use Debbugs::Common qw(:util :quit :misc :lock);
+
+use Debbugs::Status qw(:read :status :write :versions);
+
+use Debbugs::MIME qw(decode_rfc1522 encode_rfc1522);
+use Debbugs::Mail qw(send_mail_message);
+use Debbugs::User;
+use Debbugs::Recipients qw(:all);
+use HTML::Entities qw(encode_entities);
+use Debbugs::Versions::Dpkg;
+
+use Debbugs::Status qw(splitpackages);
+
+use Debbugs::CGI qw(html_escape);
+use Debbugs::Control qw(:archive :log :owner);
+use Debbugs::Log qw(:misc);
+use Debbugs::Text qw(:templates);
+
+use Mail::RFC822::Address;
+
+chdir($config{spool_dir}) or
+ die "Unable to chdir to spool_dir '$config{spool_dir}': $!";
+
+my $debug = 0;
+umask(002);
+
+my ($nn,$control) = $ARGV[0] =~ m/^(([RC])\.\d+)$/;
+if (not defined $control or not defined $nn) {
+ die "Bad argument to service.in";
+}
+if (!rename("incoming/G$nn","incoming/P$nn")) {
+ defined $! and $! =~ m/no such file or directory/i and exit 0;
+ die "Failed to rename incoming/G$nn to incoming/P$nn: $!";
+}
+
+my $log_fh = IO::File->new("incoming/P$nn",'r') or
+ die "Unable to open incoming/P$nn for reading: $!";
+my @log=<$log_fh>;
+my @msg=@log;
+close($log_fh);
+
+chomp @msg;
+
+print "###\n",join("##\n",@msg),"\n###\n" if $debug;
+
+# Bug numbers to send e-mail to, hash so that we don't send to the
+# same bug twice.
+my (%bug_affected);
+
+my (@headerlines,@bodylines);
+
+my $parse_output = Debbugs::MIME::parse(join('',@log));
+@headerlines = @{$parse_output->{header}};
+@bodylines = @{$parse_output->{body}};
+
+my %header;
+for (@headerlines) {
+ $_ = decode_rfc1522($_);
+ s/\n\s/ /g;
+ print ">$_<\n" if $debug;
+ if (s/^(\S+):\s*//) {
+ my $v = lc $1;
+ print ">$v=$_<\n" if $debug;
+ $header{$v} = $_;
+ } else {
+ print "!>$_<\n" if $debug;
+ }
+}
+$header{'message-id'} ||= '';
+
+grep(s/\s+$//,@bodylines);
+
+print "***\n",join("\n",@bodylines),"\n***\n" if $debug;
+
+if (defined $header{'resent-from'} && !defined $header{'from'}) {
+ $header{'from'} = $header{'resent-from'};
+}
+
+defined($header{'from'}) || die "no From header";
+
+delete $header{'reply-to'}
+ if ( defined($header{'reply-to'}) && $header{'reply-to'} =~ m/^\s*$/ );
+
+my $replyto;
+if ( defined($header{'reply-to'}) && $header{'reply-to'} ne "" ) {
+ $replyto = $header{'reply-to'};
+} else {
+ $replyto = $header{'from'};
+}
+
+# This is an error counter which should be incremented every time there is an error.
+my $errors = 0;
+my $controlrequestaddr= ($control ? 'control' : 'request').$config{email_domain};
+my $transcript_scalar = '';
+my $transcript = IO::Scalar->new(\$transcript_scalar) or
+ die "Unable to create new IO::Scalar";
+print {$transcript} "Processing commands for $controlrequestaddr:\n\n";
+
+# debug level
+my $dl = 0;
+my $state= 'idle';
+my $lowstate= 'idle';
+my $mergelowstate= 'idle';
+my $midix=0;
+
+my $user = $replyto;
+$user =~ s/,.*//;
+$user =~ s/^.*<(.*)>.*$/$1/;
+$user =~ s/[(].*[)]//;
+$user =~ s/^\s*(\S+)\s+.*$/$1/;
+$user = "" unless (Debbugs::User::is_valid_user($user));
+my $indicated_user = 0;
+
+my $quickabort = 0;
+
+
+if (@gExcludeFromControl and grep {$replyto =~ m/\Q$_\E/} @gExcludeFromControl) {
+ print {$transcript} fill_template('mail/excluded_from_control');
+ $quickabort = 1;
+}
+
+my %limit_pkgs = ();
+my %clonebugs = ();
+my %bcc = ();
+
+
+my @bcc;
+sub addbcc {
+ push @bcc, $_[0] unless grep { $_ eq $_[0] } @bcc;
+}
+
+our $data;
+our $message;
+our $extramessage;
+our $ref;
+
+our $mismatch;
+our $action;
+
+
+# recipients of mail
+my %recipients;
+# affected_packages
+my %affected_packages;
+my $ok = 0;
+my $unknowns = 0;
+my $procline=0;
+for ($procline=0; $procline<=$#bodylines; $procline++) {
+ my $noriginator;
+ my $newsubmitter;
+ my $oldsubmitter;
+ my $newowner;
+ $state eq 'idle' || print "state: $state ?\n";
+ $lowstate eq 'idle' || print "lowstate: $lowstate ?\n";
+ $mergelowstate eq 'idle' || print "mergelowstate: $mergelowstate ?\n";
+ if ($quickabort) {
+ print {$transcript} "Stopping processing here.\n\n";
+ last;
+ }
+ $_= $bodylines[$procline]; s/\s+$//;
+ next unless m/\S/;
+ print {$transcript} "> $_\n";
+ next if m/^\s*\#/;
+ $action= '';
+ if (m/^stop\s*$/i || m/^quit\s*$/i || m/^--\s*$/ || m/^thank(?:s|\s*you)?\s*$/i || m/^kthxbye\s*$/i) {
+ print {$transcript} "Stopping processing here.\n\n";
+ last;
+ } elsif (m/^debug\s+(\d+)$/i && $1 >= 0 && $1 <= 1000) {
+ $dl= $1+0;
+ print {$transcript} "Debug level $dl.\n\n";
+ } elsif (m/^(send|get)\s+\#?(\d{2,})$/i) {
+ $ref= $2+0;
+ &sendlynxdoc("bugreport.cgi?bug=$ref","logs for $gBug#$ref");
+ } elsif (m/^send-detail\s+\#?(\d{2,})$/i) {
+ $ref= $1+0;
+ &sendlynxdoc("bugreport.cgi?bug=$ref&boring=yes",
+ "detailed logs for $gBug#$ref");
+ } elsif (m/^index(\s+full)?$/i) {
+ print {$transcript} "This BTS function is currently disabled, sorry.\n\n";
+ $errors++;
+ $ok++; # well, it's not really ok, but it fixes #81224 :)
+ } elsif (m/^index-summary\s+by-package$/i) {
+ print {$transcript} "This BTS function is currently disabled, sorry.\n\n";
+ $errors++;
+ $ok++; # well, it's not really ok, but it fixes #81224 :)
+ } elsif (m/^index-summary(\s+by-number)?$/i) {
+ print {$transcript} "This BTS function is currently disabled, sorry.\n\n";
+ $errors++;
+ $ok++; # well, it's not really ok, but it fixes #81224 :)
+ } elsif (m/^index(\s+|-)pack(age)?s?$/i) {
+ &sendlynxdoc("pkgindex.cgi?indexon=pkg",'index of packages');
+ } elsif (m/^index(\s+|-)maints?$/i) {
+ &sendlynxdoc("pkgindex.cgi?indexon=maint",'index of maintainers');
+ } elsif (m/^index(\s+|-)maint\s+(\S+)$/i) {
+ my $maint = $2;
+ &sendlynxdoc("pkgreport.cgi?maint=" . urlsanit($maint),
+ "$gBug list for maintainer \`$maint'");
+ $ok++;
+ } elsif (m/^index(\s+|-)pack(age)?s?\s+(\S.*\S)$/i) {
+ my $package = $+;
+ &sendlynxdoc("pkgreport.cgi?pkg=" . urlsanit($package),
+ "$gBug list for package $package");
+ $ok++;
+ } elsif (m/^send-unmatched(\s+this|\s+-?0)?$/i) {
+ print {$transcript} "This BTS function is currently disabled, sorry.\n\n";
+ $errors++;
+ $ok++; # well, it's not really ok, but it fixes #81224 :)
+ } elsif (m/^send-unmatched\s+(last|-1)$/i) {
+ print {$transcript} "This BTS function is currently disabled, sorry.\n\n";
+ $errors++;
+ $ok++; # well, it's not really ok, but it fixes #81224 :)
+ } elsif (m/^send-unmatched\s+(old|-2)$/i) {
+ print {$transcript} "This BTS function is currently disabled, sorry.\n\n";
+ $errors++;
+ $ok++; # well, it's not really ok, but it fixes #81224 :)
+ } elsif (m/^getinfo\s+([\w.-]+)$/i) {
+ # the following is basically a Debian-specific kludge, but who cares
+ my $req = $1;
+ if ($req =~ /^maintainers$/i && -f "$gConfigDir/Maintainers") {
+ &sendinfo("local", "$gConfigDir/Maintainers", "Maintainers file");
+ } elsif ($req =~ /^override\.(\w+)\.([\w.-]+)$/i) {
+ $req =~ s/.gz$//;
+ &sendinfo("ftp.d.o", "$req", "override file for $2 part of $1 distribution");
+ } elsif ($req =~ /^pseudo-packages\.(description|maintainers)$/i && -f "$gConfigDir/$req") {
+ &sendinfo("local", "$gConfigDir/$req", "$req file");
+ } else {
+ print {$transcript} "Info file $req does not exist.\n\n";
+ }
+ } elsif (m/^help/i) {
+ &sendhelp;
+ print {$transcript} "\n";
+ $ok++;
+ } elsif (m/^refcard/i) {
+ &sendtxthelp("bug-mailserver-refcard.txt","mail servers' reference card");
+ } 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
+to send them to you.
+soon: MAILINGLISTS_TEXT
+END
+ } elsif (m/^unsubscribe/i) {
+ print {$transcript} <<END;
+soon: UNSUBSCRIBE_TEXT
+soon: MAILINGLISTS_TEXT
+END
+ } elsif (m/^user\s+(\S+)\s*$/i) {
+ my $newuser = $1;
+ if (Debbugs::User::is_valid_user($newuser)) {
+ my $olduser = ($user ne "" ? " (was $user)" : "");
+ print {$transcript} "Setting user to $newuser$olduser.\n";
+ $user = $newuser;
+ $indicated_user = 1;
+ } else {
+ print {$transcript} "Selected user id ($newuser) invalid, sorry\n";
+ $errors++;
+ $user = "";
+ $indicated_user = 1;
+ }
+ } elsif (m/^usercategory\s+(\S+)(\s+\[hidden\])?\s*$/i) {
+ $ok++;
+ my $catname = $1;
+ my $hidden = ($2 ne "");
+
+ my $prefix = "";
+ my @cats;
+ my $bad = 0;
+ my $catsec = 0;
+ if ($user eq "") {
+ print {$transcript} "No valid user selected\n";
+ $errors++;
+ next;
+ }
+ if (not $indicated_user and defined $user) {
+ print {$transcript} "User is $user\n";
+ $indicated_user = 1;
+ }
+ my @ords = ();
+ while (++$procline <= $#bodylines) {
+ unless ($bodylines[$procline] =~ m/^\s*([*+])\s*(\S.*)$/) {
+ $procline--;
+ last;
+ }
+ print {$transcript} "> $bodylines[$procline]\n";
+ next if $bad;
+ my ($o, $txt) = ($1, $2);
+ if ($#cats == -1 && $o eq "+") {
+ print {$transcript} "User defined category specification must start with a category name. Skipping.\n\n";
+ $errors++;
+ $bad = 1;
+ next;
+ }
+ if ($o eq "+") {
+ unless (ref($cats[-1]) eq "HASH") {
+ $cats[-1] = { "nam" => $cats[-1],
+ "pri" => [], "ttl" => [] };
+ }
+ $catsec++;
+ my ($desc, $ord, $op);
+ if ($txt =~ m/^(.*\S)\s*\[((\d+):\s*)?\]\s*$/) {
+ $desc = $1; $ord = $3; $op = "";
+ } elsif ($txt =~ m/^(.*\S)\s*\[((\d+):\s*)?(\S+)\]\s*$/) {
+ $desc = $1; $ord = $3; $op = $4;
+ } elsif ($txt =~ m/^([^[\s]+)\s*$/) {
+ $desc = ""; $op = $1;
+ } else {
+ print {$transcript} "Unrecognised syntax for category section. Skipping.\n\n";
+ $errors++;
+ $bad = 1;
+ next;
+ }
+ $ord = 999 unless defined $ord;
+
+ if ($op) {
+ push @{$cats[-1]->{"pri"}}, $prefix . $op;
+ push @{$cats[-1]->{"ttl"}}, $desc;
+ push @ords, "$ord $catsec";
+ } else {
+ $cats[-1]->{"def"} = $desc;
+ push @ords, "$ord DEF";
+ $catsec--;
+ }
+ @ords = sort { my ($a1, $a2, $b1, $b2) = split / /, "$a $b";
+ $a1 <=> $b1 || $a2 <=> $b2; } @ords;
+ $cats[-1]->{"ord"} = [map { m/^.* (\S+)/; $1 eq "DEF" ? $catsec + 1 : $1 } @ords];
+ } elsif ($o eq "*") {
+ $catsec = 0;
+ my ($name);
+ if ($txt =~ m/^(.*\S)(\s*\[(\S+)\])\s*$/) {
+ $name = $1; $prefix = $3;
+ } else {
+ $name = $txt; $prefix = "";
+ }
+ push @cats, $name;
+ }
+ }
+ # XXX: got @cats, now do something with it
+ my $u = Debbugs::User::get_user($user);
+ if (@cats) {
+ print {$transcript} "Added usercategory $catname.\n\n";
+ $u->{"categories"}->{$catname} = [ @cats ];
+ if (not $hidden) {
+ push @{$u->{visible_cats}},$catname;
+ }
+ } else {
+ print {$transcript} "Removed usercategory $catname.\n\n";
+ delete $u->{"categories"}->{$catname};
+ @{$u->{visible_cats}} = grep {$_ ne $catname} @{$u->{visible_cats}};
+ }
+ $u->write();
+ } elsif (m/^usertags?\s+\#?(-?\d+)\s+(([=+-])\s*)?(\S.*)?$/i) {
+ $ok++;
+ $ref = $1;
+ my $addsubcode = $3 || "+";
+ my $tags = $4;
+ if ($ref =~ m/^-\d+$/ && defined $clonebugs{$ref}) {
+ $ref = $clonebugs{$ref};
+ }
+ if ($user eq "") {
+ print {$transcript} "No valid user selected\n";
+ $errors++;
+ $indicated_user = 1;
+ } elsif (&setbug) {
+ if (not $indicated_user and defined $user) {
+ print {$transcript} "User is $user\n";
+ $indicated_user = 1;
+ }
+ &nochangebug;
+ my %ut;
+ Debbugs::User::read_usertags(\%ut, $user);
+ my @oldtags = (); my @newtags = (); my @badtags = ();
+ my %chtags;
+ for my $t (split /[,\s]+/, $tags) {
+ if ($t =~ m/^[a-zA-Z0-9.+\@-]+$/) {
+ $chtags{$t} = 1;
+ } else {
+ push @badtags, $t;
+ }
+ }
+ if (@badtags) {
+ print {$transcript} "Ignoring illegal tag/s: ".join(', ', @badtags).".\nPlease use only alphanumerics, at, dot, plus and dash.\n";
+ $errors++;
+ }
+ for my $t (keys %chtags) {
+ $ut{$t} = [] unless defined $ut{$t};
+ }
+ for my $t (keys %ut) {
+ my %res = map { ($_, 1) } @{$ut{$t}};
+ push @oldtags, $t if defined $res{$ref};
+ my $addop = ($addsubcode eq "+" or $addsubcode eq "=");
+ my $del = (defined $chtags{$t} ? $addsubcode eq "-"
+ : $addsubcode eq "=");
+ $res{$ref} = 1 if ($addop && defined $chtags{$t});
+ delete $res{$ref} if ($del);
+ push @newtags, $t if defined $res{$ref};
+ $ut{$t} = [ sort { $a <=> $b } (keys %res) ];
+ }
+ if (@oldtags == 0) {
+ print {$transcript} "There were no usertags set.\n";
+ } else {
+ print {$transcript} "Usertags were: " . join(" ", @oldtags) . ".\n";
+ }
+ print {$transcript} "Usertags are now: " . join(" ", @newtags) . ".\n";
+ Debbugs::User::write_usertags(\%ut, $user);
+ }
+ } elsif (!$control) {
+ print {$transcript} <<END;
+Unknown command or malformed arguments to command.
+(Use control\@$gEmailDomain to manipulate reports.)
+
+END
+ $errors++;
+ if (++$unknowns >= 3) {
+ print {$transcript} "Too many unknown commands, stopping here.\n\n";
+ last;
+ }
+#### "developer only" ones start here
+ } elsif (m/^close\s+\#?(-?\d+)(?:\s+(\d.*))?$/i) {
+ $ok++;
+ $ref= $1;
+ $bug_affected{$ref}=1;
+ my $version= $2;
+ if (&setbug) {
+ print {$transcript} "'close' is deprecated; see http://$gWebDomain/Developer$gHTMLSuffix#closing.\n";
+ if (length($data->{done}) and not defined($version)) {
+ print {$transcript} "$gBug is already closed, cannot re-close.\n\n";
+ &nochangebug;
+ } else {
+ $action= "$gBug " .
+ (defined($version) ?
+ "marked as fixed in version $version" :
+ "closed") .
+ ", send any further explanations to $data->{originator}";
+ do {
+ $affected_packages{$data->{package}} = 1;
+ add_recipients(data => $data,
+ recipients => \%recipients,
+ actions_taken => {done => 1},
+ );
+ $data->{done}= $replyto;
+ my @keywords= split ' ', $data->{keywords};
+ my $extramessage = '';
+ if (grep $_ eq 'pending', @keywords) {
+ $extramessage= "Removed pending tag.\n";
+ $data->{keywords}= join ' ', grep $_ ne 'pending',
+ @keywords;
+ }
+ addfixedversions($data, $data->{package}, $version, 'binary');
+
+ my $message= <<END;
+From: $gMaintainerEmail ($gProject $gBug Tracking System)
+To: $data->{originator}
+Subject: $gBug#$ref acknowledged by developer
+ ($header{'subject'})
+References: $header{'message-id'} $data->{msgid}
+In-Reply-To: $data->{msgid}
+Message-ID: <handler.$ref.$nn.notifdonectrl.$midix\@$gEmailDomain>
+Reply-To: $ref\@$gEmailDomain
+X-$gProject-PR-Message: they-closed-control $ref
+
+This is an automatic notification regarding your $gBug report
+#$ref: $data->{subject},
+which was filed against the $data->{package} package.
+
+It has been marked as closed by one of the developers, namely
+$replyto.
+
+You should be hearing from them with a substantive response shortly,
+in case you haven't already. If not, please contact them directly.
+
+$gMaintainer
+(administrator, $gProject $gBugs database)
+
+END
+ &sendmailmessage($message,$data->{originator});
+ } while (&getnextbug);
+ }
+ }
+ } elsif (m/^reassign\s+\#?(-?\d+)\s+(\S+)(?:\s+(\d.*))?$/i) {
+ $ok++;
+ $ref= $1;
+ my $newpackage= $2;
+ $bug_affected{$ref}=1;
+ my $version= $3;
+ $newpackage =~ y/A-Z/a-z/;
+ if (&setbug) {
+ if (length($data->{package})) {
+ $action= "$gBug reassigned from package \`$data->{package}'".
+ " to \`$newpackage'.";
+ } else {
+ $action= "$gBug assigned to package \`$newpackage'.";
+ }
+ do {
+ $affected_packages{$data->{package}} = 1;
+ add_recipients(data => $data, recipients => \%recipients);
+ $data->{package}= $newpackage;
+ $data->{found_versions}= [];
+ $data->{fixed_versions}= [];
+ # TODO: what if $newpackage is a source package?
+ addfoundversions($data, $data->{package}, $version, 'binary');
+ add_recipients(data => $data, recipients => \%recipients);
+ } while (&getnextbug);
+ }
+ } elsif (m/^reopen\s+\#?(-?\d+)$/i ? ($noriginator='', 1) :
+ m/^reopen\s+\#?(-?\d+)\s+\=$/i ? ($noriginator='', 1) :
+ m/^reopen\s+\#?(-?\d+)\s+\!$/i ? ($noriginator=$replyto, 1) :
+ m/^reopen\s+\#?(-?\d+)\s+(\S.*\S)$/i ? ($noriginator=$2, 1) : 0) {
+ $ok++;
+ $ref= $1;
+ $bug_affected{$ref}=1;
+ if (&setbug) {
+ if (@{$data->{fixed_versions}}) {
+ print {$transcript} "'reopen' may be inappropriate when a bug has been closed with a version;\nyou may need to use 'found' to remove fixed versions.\n";
+ }
+ if (!length($data->{done})) {
+ print {$transcript} "$gBug is already open, cannot reopen.\n\n";
+ &nochangebug;
+ } else {
+ $action=
+ $noriginator eq '' ? "$gBug reopened, originator not changed." :
+ "$gBug reopened, originator set to $noriginator.";
+ do {
+ $affected_packages{$data->{package}} = 1;
+ add_recipients(data => $data, recipients => \%recipients);
+ $data->{originator}= $noriginator eq '' ? $data->{originator} : $noriginator;
+ $data->{fixed_versions}= [];
+ $data->{done}= '';
+ } while (&getnextbug);
+ }
+ }
+ } elsif (m{^found\s+\#?(-?\d+)
+ (?:\s+((?:$config{package_name_re}\/)?
+ $config{package_version_re}))?$}ix) {
+ $ok++;
+ $ref= $1;
+ my $version= $2;
+ if (&setbug) {
+ if (!length($data->{done}) and not defined($version)) {
+ print {$transcript} "$gBug is already open, cannot reopen.\n\n";
+ $errors++;
+ &nochangebug;
+ } else {
+ $action=
+ defined($version) ?
+ "$gBug marked as found in version $version." :
+ "$gBug reopened.";
+ do {
+ $affected_packages{$data->{package}} = 1;
+ add_recipients(data => $data, recipients => \%recipients);
+ # The 'done' field gets a bit weird with version
+ # tracking, because a bug may be closed by multiple
+ # people in different branches. Until we have something
+ # more flexible, we set it every time a bug is fixed,
+ # and clear it when a bug is found in a version greater
+ # than any version in which the bug is fixed or when
+ # a bug is found and there is no fixed version
+ if (defined $version) {
+ my ($version_only) = $version =~ m{([^/]+)$};
+ addfoundversions($data, $data->{package}, $version, 'binary');
+ my @fixed_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
+ map {s{.+/}{}; $_;} @{$data->{fixed_versions}};
+ if (not @fixed_order or (Debbugs::Versions::Dpkg::vercmp($version_only,$fixed_order[-1]) >= 0)) {
+ $action = "$gBug marked as found in version $version and reopened."
+ if length $data->{done};
+ $data->{done} = '';
+ }
+ } else {
+ # Versionless found; assume old-style "not fixed at
+ # all".
+ $data->{fixed_versions} = [];
+ $data->{done} = '';
+ }
+ } while (&getnextbug);
+ }
+ }
+ } elsif (m[^notfound\s+\#?(-?\d+)\s+
+ ((?:$config{package_name_re}\/)?
+ \S+)\s*$]ix) {
+ $ok++;
+ $ref= $1;
+ my $version= $2;
+ if (&setbug) {
+ $action= "$gBug no longer marked as found in version $version.";
+ if (length($data->{done})) {
+ $extramessage= "(By the way, this $gBug is currently marked as done.)\n";
+ }
+ do {
+ $affected_packages{$data->{package}} = 1;
+ add_recipients(data => $data, recipients => \%recipients);
+ removefoundversions($data, $data->{package}, $version, 'binary');
+ } while (&getnextbug);
+ }
+ }
+ elsif (m[^fixed\s+\#?(-?\d+)\s+
+ ((?:$config{package_name_re}\/)?
+ $config{package_version_re})\s*$]ix) {
+ $ok++;
+ $ref= $1;
+ my $version= $2;
+ if (&setbug) {
+ $action=
+ defined($version) ?
+ "$gBug marked as fixed in version $version." :
+ "$gBug reopened.";
+ do {
+ $affected_packages{$data->{package}} = 1;
+ add_recipients(data => $data, recipients => \%recipients);
+ addfixedversions($data, $data->{package}, $version, 'binary');
+ } while (&getnextbug);
+ }
+ }
+ elsif (m[^notfixed\s+\#?(-?\d+)\s+
+ ((?:$config{package_name_re}\/)?
+ \S+)\s*$]ix) {
+ $ok++;
+ $ref= $1;
+ my $version= $2;
+ if (&setbug) {
+ $action=
+ defined($version) ?
+ "$gBug no longer marked as fixed in version $version." :
+ "$gBug reopened.";
+ do {
+ $affected_packages{$data->{package}} = 1;
+ add_recipients(data => $data, recipients => \%recipients);
+ removefixedversions($data, $data->{package}, $version, 'binary');
+ } while (&getnextbug);
+ }
+ }
+ elsif (m/^submitter\s+\#?(-?\d+)\s+\!$/i ? ($newsubmitter=$replyto, 1) :
+ m/^submitter\s+\#?(-?\d+)\s+(\S.*\S)$/i ? ($newsubmitter=$2, 1) : 0) {
+ $ok++;
+ $ref= $1;
+ $bug_affected{$ref}=1;
+ if ($ref =~ m/^-\d+$/ && defined $clonebugs{$ref}) {
+ $ref = $clonebugs{$ref};
+ }
+ if (not Mail::RFC822::Address::valid($newsubmitter)) {
+ transcript("$newsubmitter is not a valid e-mail address; not changing submitter\n");
+ $errors++;
+ }
+ elsif (&getbug) {
+ if (&checkpkglimit) {
+ &foundbug;
+ $affected_packages{$data->{package}} = 1;
+ add_recipients(data => $data, recipients => \%recipients);
+ $oldsubmitter= $data->{originator};
+ $data->{originator}= $newsubmitter;
+ $action= "Changed $gBug submitter from $oldsubmitter to $newsubmitter.";
+ &savebug;
+ print {$transcript} "$action\n";
+ if (length($data->{done})) {
+ print {$transcript} "(By the way, that $gBug is currently marked as done.)\n";
+ }
+ print {$transcript} "\n";
+ $message= <<END;
+From: $gMaintainerEmail ($gProject $gBug Tracking System)
+To: $oldsubmitter
+Subject: $gBug#$ref submitter address changed
+ ($header{'subject'})
+References: $header{'message-id'} $data->{msgid}
+In-Reply-To: $data->{msgid}
+Message-ID: <handler.$ref.$nn.newsubmitter.$midix\@$gEmailDomain>
+Reply-To: $ref\@$gEmailDomain
+X-$gProject-PR-Message: submitter-changed $ref
+
+The submitter address recorded for your $gBug report
+#$ref: $data->{subject}
+has been changed.
+
+The old submitter address for this report was
+$oldsubmitter.
+The new submitter address is
+$newsubmitter.
+
+This change was made by
+$replyto.
+If it was incorrect, please contact them directly.
+
+$gMaintainer
+(administrator, $gProject $gBugs database)
+
+END
+ &sendmailmessage($message,$oldsubmitter);
+ } else {
+ &cancelbug;
+ }
+ } else {
+ ¬foundbug;
+ }
+ } elsif (m/^forwarded\s+\#?(-?\d+)\s+(\S.*\S)$/i) {
+ $ok++;
+ $ref= $1;
+ my $whereto= $2;
+ $bug_affected{$ref}=1;
+ if (&setbug) {
+ if (length($data->{forwarded})) {
+ $action= "Forwarded-to-address changed from $data->{forwarded} to $whereto.";
+ } else {
+ $action= "Noted your statement that $gBug has been forwarded to $whereto.";
+ }
+ if (length($data->{done})) {
+ $extramessage= "(By the way, this $gBug is currently marked as done.)\n";
+ }
+ do {
+ $affected_packages{$data->{package}} = 1;
+ add_recipients(data => $data,
+ recipients => \%recipients,
+ actions_taken => {forwarded => 1},
+ );
+ $data->{forwarded}= $whereto;
+ } while (&getnextbug);
+ }
+ } elsif (m/^notforwarded\s+\#?(-?\d+)$/i) {
+ $ok++;
+ $ref= $1;
+ $bug_affected{$ref}=1;
+ if (&setbug) {
+ if (!length($data->{forwarded})) {
+ print {$transcript} "$gBug is not marked as having been forwarded.\n\n";
+ &nochangebug;
+ } else {
+ $action= "Removed annotation that $gBug had been forwarded to $data->{forwarded}.";
+ do {
+ $affected_packages{$data->{package}} = 1;
+ add_recipients(data => $data, recipients => \%recipients);
+ $data->{forwarded}= '';
+ } while (&getnextbug);
+ }
+ }
+ } elsif (m/^severity\s+\#?(-?\d+)\s+([-0-9a-z]+)$/i ||
+ m/^priority\s+\#?(-?\d+)\s+([-0-9a-z]+)$/i) {
+ $ok++;
+ $ref= $1;
+ $bug_affected{$ref}=1;
+ my $newseverity= $2;
+ if (!grep($_ eq $newseverity, @gSeverityList, "$gDefaultSeverity")) {
+ print {$transcript} "Severity level \`$newseverity' is not known.\n".
+ "Recognized are: $gShowSeverities.\n\n";
+ $errors++;
+ } elsif (exists $gObsoleteSeverities{$newseverity}) {
+ print {$transcript} "Severity level \`$newseverity' is obsolete. " .
+ "Use $gObsoleteSeverities{$newseverity} instead.\n\n";
+ $errors++;
+ } elsif (&setbug) {
+ my $printseverity= $data->{severity};
+ $printseverity= "$gDefaultSeverity" if $printseverity eq '';
+ $action= "Severity set to \`$newseverity' from \`$printseverity'";
+ do {
+ $affected_packages{$data->{package}} = 1;
+ add_recipients(data => $data, recipients => \%recipients);
+ if (defined $gStrongList and isstrongseverity($newseverity)) {
+ addbcc("$gStrongList\@$gListDomain");
+ }
+ $data->{severity}= $newseverity;
+ } while (&getnextbug);
+ }
+ } elsif (m/^tags?\s+\#?(-?\d+)\s+(([=+-])\s*)?(\S.*)?$/i) {
+ $ok++;
+ $ref = $1;
+ my $addsubcode = $3;
+ my $tags = $4;
+ $bug_affected{$ref}=1;
+ my $addsub = "add";
+ if (defined $addsubcode) {
+ $addsub = "sub" if ($addsubcode eq "-");
+ $addsub = "add" if ($addsubcode eq "+");
+ $addsub = "set" if ($addsubcode eq "=");
+ }
+ my @okaytags = ();
+ my @badtags = ();
+ foreach my $t (split /[\s,]+/, $tags) {
+ if (!grep($_ eq $t, @gTags)) {
+ push @badtags, $t;
+ } else {
+ push @okaytags, $t;
+ }
+ }
+ if (@badtags) {
+ print {$transcript} "Unknown tag/s: ".join(', ', @badtags).".\n".
+ "Recognized are: ".join(' ', @gTags).".\n\n";
+ $errors++;
+ }
+ if (&setbug) {
+ if ($data->{keywords} eq '') {
+ print {$transcript} "There were no tags set.\n";
+ } else {
+ print {$transcript} "Tags were: $data->{keywords}\n";
+ }
+ if ($addsub eq "set") {
+ $action= "Tags set to: " . join(", ", @okaytags);
+ } elsif ($addsub eq "add") {
+ $action= "Tags added: " . join(", ", @okaytags);
+ } elsif ($addsub eq "sub") {
+ $action= "Tags removed: " . join(", ", @okaytags);
+ }
+ do {
+ $affected_packages{$data->{package}} = 1;
+ add_recipients(data => $data, recipients => \%recipients);
+ $data->{keywords} = '' if ($addsub eq "set");
+ # Allow removing obsolete tags.
+ if ($addsub eq "sub") {
+ foreach my $t (@badtags) {
+ $data->{keywords} = join ' ', grep $_ ne $t,
+ split ' ', $data->{keywords};
+ }
+ }
+ # Now process all other additions and subtractions.
+ foreach my $t (@okaytags) {
+ $data->{keywords} = join ' ', grep $_ ne $t,
+ split ' ', $data->{keywords};
+ $data->{keywords} = "$t $data->{keywords}" unless($addsub eq "sub");
+ }
+ $data->{keywords} =~ s/\s*$//;
+ } while (&getnextbug);
+ }
+ } elsif (m/^(un)?block\s+\#?(-?\d+)\s+(by|with)\s+(\S.*)?$/i) {
+ $ok++;
+ my $bugnum = $2; my $blockers = $4;
+ my $addsub = "add";
+ $addsub = "sub" if ($1 eq "un");
+ if ($bugnum =~ m/^-\d+$/ && defined $clonebugs{$bugnum}) {
+ $bugnum = $clonebugs{$bugnum};
+ }
+
+ my @okayblockers;
+ my @badblockers;
+ foreach my $b (split /[\s,]+/, $blockers) {
+ $b=~s/^\#//;
+ if ($b=~/[0-9]+/) {
+ $ref=$b;
+ if ($ref =~ m/^-\d+$/ && defined $clonebugs{$ref}) {
+ $ref = $clonebugs{$ref};
+ }
+ if (&getbug) {
+ &foundbug;
+ push @okayblockers, $ref;
+
+ # add to the list all bugs that are merged with $b,
+ # because all of their data must be kept in sync
+ my @thisbugmergelist= split(/ /,$data->{mergedwith});
+ &cancelbug;
+
+ foreach $ref (@thisbugmergelist) {
+ if (&getbug) {
+ push @okayblockers, $ref;
+ &cancelbug;
+ }
+ }
+ }
+ else {
+ ¬foundbug;
+ push @badblockers, $ref;
+ }
+ }
+ else {
+ push @badblockers, $b;
+ }
+ }
+ if (@badblockers) {
+ print {$transcript} "Unknown blocking bug/s: ".join(', ', @badblockers).".\n";
+ $errors++;
+ }
+
+ $ref=$bugnum;
+ if (&setbug) {
+ if ($data->{blockedby} eq '') {
+ print {$transcript} "Was not blocked by any bugs.\n";
+ } else {
+ print {$transcript} "Was blocked by: $data->{blockedby}\n";
+ }
+ if ($addsub eq "set") {
+ $action= "Blocking bugs of $bugnum set to: " . join(", ", @okayblockers);
+ } elsif ($addsub eq "add") {
+ $action= "Blocking bugs of $bugnum added: " . join(", ", @okayblockers);
+ } elsif ($addsub eq "sub") {
+ $action= "Blocking bugs of $bugnum removed: " . join(", ", @okayblockers);
+ }
+ my %removedblocks;
+ my %addedblocks;
+ do {
+ $affected_packages{$data->{package}} = 1;
+ add_recipients(data => $data, recipients => \%recipients);
+ my @oldblockerlist = split ' ', $data->{blockedby};
+ $data->{blockedby} = '' if ($addsub eq "set");
+ foreach my $b (@okayblockers) {
+ $data->{blockedby} = manipset($data->{blockedby}, $b,
+ ($addsub ne "sub"));
+ }
+
+ foreach my $b (@oldblockerlist) {
+ if (! grep { $_ eq $b } split ' ', $data->{blockedby}) {
+ push @{$removedblocks{$b}}, $ref;
+ }
+ }
+ foreach my $b (split ' ', $data->{blockedby}) {
+ if (! grep { $_ eq $b } @oldblockerlist) {
+ push @{$addedblocks{$b}}, $ref;
+ }
+ }
+ } while (&getnextbug);
+
+ # Now that the blockedby data is updated, change blocks data
+ # to match the changes.
+ foreach $ref (keys %addedblocks) {
+ if (&getbug) {
+ foreach my $b (@{$addedblocks{$ref}}) {
+ $data->{blocks} = manipset($data->{blocks}, $b, 1);
+ }
+ &savebug;
+ }
+ }
+ foreach $ref (keys %removedblocks) {
+ if (&getbug) {
+ foreach my $b (@{$removedblocks{$ref}}) {
+ $data->{blocks} = manipset($data->{blocks}, $b, 0);
+ }
+ &savebug;
+ }
+ }
+ }
+ } elsif (m/^retitle\s+\#?(-?\d+)\s+(\S.*\S)\s*$/i) {
+ $ok++;
+ $ref= $1; my $newtitle= $2;
+ $bug_affected{$ref}=1;
+ if ($ref =~ m/^-\d+$/ && defined $clonebugs{$ref}) {
+ $ref = $clonebugs{$ref};
+ }
+ if (&getbug) {
+ if (&checkpkglimit) {
+ &foundbug;
+ $affected_packages{$data->{package}} = 1;
+ add_recipients(data => $data, recipients => \%recipients);
+ my $oldtitle = $data->{subject};
+ $data->{subject}= $newtitle;
+ $action= "Changed $gBug title to `$newtitle' from `$oldtitle'.";
+ &savebug;
+ print {$transcript} "$action\n";
+ if (length($data->{done})) {
+ print {$transcript} "(By the way, that $gBug is currently marked as done.)\n";
+ }
+ print {$transcript} "\n";
+ } else {
+ &cancelbug;
+ }
+ } else {
+ ¬foundbug;
+ }
+ } elsif (m/^unmerge\s+\#?(-?\d+)$/i) {
+ $ok++;
+ $ref= $1;
+ $bug_affected{$ref} = 1;
+ if (&setbug) {
+ if (!length($data->{mergedwith})) {
+ print {$transcript} "$gBug is not marked as being merged with any others.\n\n";
+ &nochangebug;
+ } else {
+ $mergelowstate eq 'locked' || die "$mergelowstate ?";
+ $action= "Disconnected #$ref from all other report(s).";
+ my @newmergelist= split(/ /,$data->{mergedwith});
+ my $discref= $ref;
+ @bug_affected{@newmergelist} = 1 x @newmergelist;
+ do {
+ $affected_packages{$data->{package}} = 1;
+ add_recipients(data => $data, recipients => \%recipients);
+ $data->{mergedwith}= ($ref == $discref) ? ''
+ : join(' ',grep($_ ne $ref,@newmergelist));
+ } while (&getnextbug);
+ }
+ }
+ } elsif (m/^merge\s+#?(-?\d+(\s+#?-?\d+)+)\s*$/i) {
+ $ok++;
+ my @tomerge= sort { $a <=> $b } split(/\s+#?/,$1);
+ my @newmergelist= ();
+ my %tags = ();
+ my %found = ();
+ my %fixed = ();
+ &getmerge;
+ while (defined($ref= shift(@tomerge))) {
+ print {$transcript} "D| checking merge $ref\n" if $dl;
+ $ref+= 0;
+ if ($ref =~ m/^-\d+$/ && defined $clonebugs{$ref}) {
+ $ref = $clonebugs{$ref};
+ }
+ next if grep($_ == $ref,@newmergelist);
+ if (!&getbug) { ¬foundbug; @newmergelist=(); last }
+ if (!&checkpkglimit) { &cancelbug; @newmergelist=(); last; }
+ &foundbug;
+ print {$transcript} "D| adding $ref ($data->{mergedwith})\n" if $dl;
+ $mismatch= '';
+ &checkmatch('package','m_package',$data->{package},@newmergelist);
+ &checkmatch('forwarded addr','m_forwarded',$data->{forwarded},@newmergelist);
+ $data->{severity} = '$gDefaultSeverity' if $data->{severity} eq '';
+ &checkmatch('severity','m_severity',$data->{severity},@newmergelist);
+ &checkmatch('blocks','m_blocks',$data->{blocks},@newmergelist);
+ &checkmatch('blocked-by','m_blockedby',$data->{blockedby},@newmergelist);
+ &checkmatch('done mark','m_done',length($data->{done}) ? 'done' : 'open',@newmergelist);
+ &checkmatch('owner','m_owner',$data->{owner},@newmergelist);
+ foreach my $t (split /\s+/, $data->{keywords}) { $tags{$t} = 1; }
+ foreach my $f (@{$data->{found_versions}}) { $found{$f} = 1; }
+ foreach my $f (@{$data->{fixed_versions}}) { $fixed{$f} = 1; }
+ if (length($mismatch)) {
+ print {$transcript} "Mismatch - only $gBugs in same state can be merged:\n".
+ $mismatch."\n";
+ $errors++;
+ &cancelbug; @newmergelist=(); last;
+ }
+ push(@newmergelist,$ref);
+ push(@tomerge,split(/ /,$data->{mergedwith}));
+ &cancelbug;
+ }
+ if (@newmergelist) {
+ @newmergelist= sort { $a <=> $b } @newmergelist;
+ $action= "Merged @newmergelist.";
+ delete @fixed{keys %found};
+ for $ref (@newmergelist) {
+ &getbug || die "huh ? $gBug $ref disappeared during merge";
+ $affected_packages{$data->{package}} = 1;
+ add_recipients(data => $data, recipients => \%recipients);
+ @bug_affected{@newmergelist} = 1 x @newmergelist;
+ $data->{mergedwith}= join(' ',grep($_ != $ref,@newmergelist));
+ $data->{keywords}= join(' ', keys %tags);
+ $data->{found_versions}= [sort keys %found];
+ $data->{fixed_versions}= [sort keys %fixed];
+ &savebug;
+ }
+ print {$transcript} "$action\n\n";
+ }
+ &endmerge;
+ } elsif (m/^forcemerge\s+\#?(-?\d+(?:\s+\#?-?\d+)+)\s*$/i) {
+ $ok++;
+ my @temp = split /\s+\#?/,$1;
+ my $master_bug = shift @temp;
+ my $master_bug_data;
+ my @tomerge = sort { $a <=> $b } @temp;
+ unshift @tomerge,$master_bug;
+ print {$transcript} "D| force merging ".join(',',@tomerge)."\n" if $dl;
+ my @newmergelist= ();
+ my %tags = ();
+ my %found = ();
+ my %fixed = ();
+ # Here we try to do the right thing.
+ # First, if the bugs are in the same package, we merge all of the found, fixed, and tags.
+ # If not, we discard the found and fixed.
+ # Everything else we set to the values of the first bug.
+ &getmerge;
+ while (defined($ref= shift(@tomerge))) {
+ print {$transcript} "D| checking merge $ref\n" if $dl;
+ $ref+= 0;
+ if ($ref =~ m/^-\d+$/ && defined $clonebugs{$ref}) {
+ $ref = $clonebugs{$ref};
+ }
+ next if grep($_ == $ref,@newmergelist);
+ if (!&getbug) { ¬foundbug; @newmergelist=(); last }
+ if (!&checkpkglimit) { &cancelbug; @newmergelist=(); last; }
+ &foundbug;
+ print {$transcript} "D| adding $ref ($data->{mergedwith})\n" if $dl;
+ $master_bug_data = $data if not defined $master_bug_data;
+ if ($data->{package} ne $master_bug_data->{package}) {
+ print {$transcript} "Mismatch - only $gBugs in the same package can be forcibly merged:\n".
+ "$gBug $ref is not in the same package as $master_bug\n";
+ $errors++;
+ &cancelbug; @newmergelist=(); last;
+ }
+ for my $t (split /\s+/,$data->{keywords}) {
+ $tags{$t} = 1;
+ }
+ @found{@{$data->{found_versions}}} = (1) x @{$data->{found_versions}};
+ @fixed{@{$data->{fixed_versions}}} = (1) x @{$data->{fixed_versions}};
+ push(@newmergelist,$ref);
+ push(@tomerge,split(/ /,$data->{mergedwith}));
+ &cancelbug;
+ }
+ if (@newmergelist) {
+ @newmergelist= sort { $a <=> $b } @newmergelist;
+ $action= "Forcibly Merged @newmergelist.";
+ delete @fixed{keys %found};
+ for $ref (@newmergelist) {
+ &getbug || die "huh ? $gBug $ref disappeared during merge";
+ $affected_packages{$data->{package}} = 1;
+ add_recipients(data => $data, recipients => \%recipients);
+ @bug_affected{@newmergelist} = 1 x @newmergelist;
+ $data->{mergedwith}= join(' ',grep($_ != $ref,@newmergelist));
+ $data->{keywords}= join(' ', keys %tags);
+ $data->{found_versions}= [sort keys %found];
+ $data->{fixed_versions}= [sort keys %fixed];
+ my @field_list = qw(forwarded package severity blocks blockedby owner done);
+ @{$data}{@field_list} = @{$master_bug_data}{@field_list};
+ &savebug;
+ }
+ print {$transcript} "$action\n\n";
+ }
+ &endmerge;
+ } elsif (m/^clone\s+#?(\d+)\s+((-\d+\s+)*-\d+)\s*$/i) {
+ $ok++;
+
+ my $origref = $1;
+ my @newclonedids = split /\s+/, $2;
+ my $newbugsneeded = scalar(@newclonedids);
+
+ $ref = $origref;
+ $bug_affected{$ref} = 1;
+ if (&setbug) {
+ $affected_packages{$data->{package}} = 1;
+ if (length($data->{mergedwith})) {
+ print {$transcript} "$gBug is marked as being merged with others. Use an existing clone.\n\n";
+ $errors++;
+ &nochangebug;
+ } else {
+ &filelock("nextnumber.lock");
+ open(N,"nextnumber") || die "nextnumber: read: $!";
+ my $v=<N>; $v =~ s/\n$// || die "nextnumber bad format";
+ my $firstref= $v+0; $v += $newbugsneeded;
+ open(NN,">nextnumber"); print NN "$v\n"; close(NN);
+ &unfilelock;
+
+ my $lastref = $firstref + $newbugsneeded - 1;
+
+ if ($newbugsneeded == 1) {
+ $action= "$gBug $origref cloned as bug $firstref.";
+ } else {
+ $action= "$gBug $origref cloned as bugs $firstref-$lastref.";
+ }
+
+ my $blocks = $data->{blocks};
+ my $blockedby = $data->{blockedby};
+
+ &getnextbug;
+ my $ohash = get_hashname($origref);
+ my $clone = $firstref;
+ @bug_affected{@newclonedids} = 1 x @newclonedids;
+ for my $newclonedid (@newclonedids) {
+ $clonebugs{$newclonedid} = $clone;
+
+ my $hash = get_hashname($clone);
+ copy("db-h/$ohash/$origref.log", "db-h/$hash/$clone.log");
+ copy("db-h/$ohash/$origref.status", "db-h/$hash/$clone.status");
+ copy("db-h/$ohash/$origref.summary", "db-h/$hash/$clone.summary");
+ copy("db-h/$ohash/$origref.report", "db-h/$hash/$clone.report");
+ &bughook('new', $clone, $data);
+
+ # Update blocking info of bugs blocked by or blocking the
+ # cloned bug.
+ foreach $ref (split ' ', $blocks) {
+ &getbug;
+ $data->{blockedby} = manipset($data->{blockedby}, $clone, 1);
+ &savebug;
+ }
+ foreach $ref (split ' ', $blockedby) {
+ &getbug;
+ $data->{blocks} = manipset($data->{blocks}, $clone, 1);
+ &savebug;
+ }
+
+ $clone++;
+ }
+ }
+ }
+ } elsif (m/^package\:?\s+(\S.*\S)?\s*$/i) {
+ $ok++;
+ my @pkgs = split /\s+/, $1;
+ if (scalar(@pkgs) > 0) {
+ %limit_pkgs = map { ($_, 1) } @pkgs;
+ print {$transcript} "Ignoring bugs not assigned to: " .
+ join(" ", keys(%limit_pkgs)) . "\n\n";
+ } else {
+ %limit_pkgs = ();
+ print {$transcript} "Not ignoring any bugs.\n\n";
+ }
+ } elsif (m/^owner\s+\#?(-?\d+)\s+((?:\S.*\S)|\!)\s*$/i) {
+ $ok++;
+ $ref = $1;
+ my $newowner = $2;
+ if ($newowner eq '!') {
+ $newowner = $replyto;
+ }
+ $bug_affected{$ref} = 1;
+ eval {
+ owner(bug => $ref,
+ transcript => $transcript,
+ ($dl > 0 ? (debug => $transcript):()),
+ requester => $header{from},
+ request_addr => $controlrequestaddr,
+ message => \@log,
+ recipients => \%recipients,
+ owner => $newowner,
+ );
+ };
+ } elsif (m/^noowner\s+\#?(-?\d+)\s*$/i) {
+ $ok++;
+ $ref = $1;
+ $bug_affected{$ref} = 1;
+ eval {
+ owner(bug => $ref,
+ transcript => $transcript,
+ ($dl > 0 ? (debug => $transcript):()),
+ requester => $header{from},
+ request_addr => $controlrequestaddr,
+ message => \@log,
+ recipients => \%recipients,
+ owner => undef,
+ );
+ };
+ if ($@) {
+ $errors++;
+ print {$transcript} "Failed to mark $ref as not having an owner: $@";
+ }
+ } elsif (m/^unarchive\s+#?(\d+)$/i) {
+ $ok++;
+ $ref = $1;
+ $bug_affected{$ref} = 1;
+ eval {
+ bug_unarchive(bug => $ref,
+ transcript => $transcript,
+ ($dl > 0 ? (debug => $transcript):()),
+ affected_bugs => \%bug_affected,
+ requester => $header{from},
+ request_addr => $controlrequestaddr,
+ message => \@log,
+ recipients => \%recipients,
+ );
+ };
+ if ($@) {
+ $errors++;
+ }
+ } elsif (m/^archive\s+#?(\d+)$/i) {
+ $ok++;
+ $ref = $1;
+ $bug_affected{$ref} = 1;
+ eval {
+ bug_archive(bug => $ref,
+ transcript => $transcript,
+ ($dl > 0 ? (debug => $transcript):()),
+ ignore_time => 1,
+ archive_unarchived => 0,
+ affected_bugs => \%bug_affected,
+ requester => $header{from},
+ request_addr => $controlrequestaddr,
+ message => \@log,
+ recipients => \%recipients,
+ );
+ };
+ if ($@) {
+ $errors++;
+ }
+ } else {
+ print {$transcript} "Unknown command or malformed arguments to command.\n\n";
+ $errors++;
+ if (++$unknowns >= 5) {
+ print {$transcript} "Too many unknown commands, stopping here.\n\n";
+ last;
+ }
+ }
+}
+if ($procline>$#bodylines) {
+ print {$transcript} ">\nEnd of message, stopping processing here.\n\n";
+}
+if (!$ok && !$quickabort) {
+ $errors++;
+ print {$transcript} "No commands successfully parsed; sending the help text(s).\n";
+ &sendhelp;
+ print {$transcript} "\n";
+}
+
+my @maintccs = determine_recipients(recipients => \%recipients,
+ address_only => 1,
+ cc => 1,
+ );
+my $maintccs = 'Cc: '.join(",\n ",
+ determine_recipients(recipients => \%recipients,
+ cc => 1,
+ )
+ )."\n";
+
+my $packagepr = '';
+$packagepr = "X-${gProject}-PR-Package: " . join(keys %affected_packages) . "\n" if keys %affected_packages;
+
+# Add Bcc's to subscribed bugs
+# now handled by Debbugs::Recipients
+#push @bcc, map {"bugs=$_\@$gListDomain"} keys %bug_affected;
+
+if (!defined $header{'subject'} || $header{'subject'} eq "") {
+ $header{'subject'} = "your mail";
+}
+
+# Error text here advertises how many errors there were
+my $error_text = $errors > 0 ? " (with $errors errors)":'';
+
+my $reply= <<END;
+From: $gMaintainerEmail ($gProject $gBug Tracking System)
+To: $replyto
+${maintccs}Subject: Processed${error_text}: $header{'subject'}
+In-Reply-To: $header{'message-id'}
+END
+$reply .= <<END;
+References: $header{'message-id'}
+Message-ID: <handler.s.$nn.transcript\@$gEmailDomain>
+Precedence: bulk
+${packagepr}X-$gProject-PR-Message: transcript
+
+${transcript_scalar}Please contact me if you need assistance.
+
+$gMaintainer
+(administrator, $gProject $gBugs database)
+END
+
+my $repliedshow= join(', ',$replyto,
+ determine_recipients(recipients => \%recipients,
+ cc => 1,
+ address_only => 1,
+ )
+ );
+# -1 is the service.in log
+&filelock("lock/-1");
+open(AP,">>db-h/-1.log") || die "open db-h/-1.log: $!";
+print(AP
+ "\2\n$repliedshow\n\5\n$reply\n\3\n".
+ "\6\n".
+ "<strong>Request received</strong> from <code>".
+ html_escape($header{'from'})."</code>\n".
+ "to <code>".html_escape($controlrequestaddr)."</code>\n".
+ "\3\n".
+ "\7\n",escape_log(@log),"\n\3\n") || die "writing db-h/-1.log: $!";
+close(AP) || die "open db-h/-1.log: $!";
+&unfilelock;
+utime(time,time,"db-h");
+
+&sendmailmessage($reply,
+ exists $header{'x-debbugs-no-ack'}?():$replyto,
+ make_list(values %{{determine_recipients(recipients => \%recipients,
+ address_only => 1,
+ )}}
+ ),
+ );
+
+unlink("incoming/P$nn") || die "unlinking incoming/P$nn: $!";
+
+sub sendmailmessage {
+ my ($message,@recips) = @_;
+ $message = "X-Loop: $gMaintainerEmail\n" . $message;
+ send_mail_message(message => $message,
+ recipients => \@recips,
+ );
+ $midix++;
+}
+
+sub fill_template{
+ my ($template,$extra_var) = @_;
+ $extra_var ||={};
+ my $variables = {config => \%config,
+ defined($ref)?(ref => $ref):(),
+ defined($data)?(data => $data):(),
+ %{$extra_var},
+ };
+ my $hole_var = {'&bugurl' =>
+ sub{"$_[0]: ".
+ 'http://'.$config{cgi_domain}.'/'.
+ Debbugs::CGI::bug_url($_[0]);
+ }
+ };
+ return fill_in_template(template => $template,
+ variables => $variables,
+ hole_var => $hole_var,
+ );
+}
+
+=head2 message_body_template
+
+ message_body_template('mail/ack',{ref=>'foo'});
+
+Creates a message body using a template
+
+=cut
+
+sub message_body_template{
+ my ($template,$extra_var) = @_;
+ $extra_var ||={};
+ my $body = fill_template($template,$extra_var);
+ return fill_template('mail/message_body',
+ {%{$extra_var},
+ body => $body,
+ },
+ );
+}
+
+sub sendhelp {
+ &sendtxthelpraw("bug-log-mailserver.txt","instructions for request\@$gEmailDomain");
+ &sendtxthelpraw("bug-maint-mailcontrol.txt","instructions for control\@$gEmailDomain")
+ if $control;
+}
+
+#sub unimplemented {
+# print {$transcript} "Sorry, command $_[0] not yet implemented.\n\n";
+#}
+
+sub checkmatch {
+ my ($string,$mvarname,$svarvalue,@newmergelist) = @_;
+ my ($mvarvalue);
+ if (@newmergelist) {
+ eval "\$mvarvalue= \$$mvarname";
+ print {$transcript} "D| checkmatch \`$string' /$mvarname/$mvarvalue/$svarvalue/\n"
+ if $dl;
+ $mismatch .=
+ "Values for \`$string' don't match:\n".
+ " #$newmergelist[0] has \`$mvarvalue';\n".
+ " #$ref has \`$svarvalue'\n"
+ if $mvarvalue ne $svarvalue;
+ } else {
+ print {$transcript} "D| setupmatch \`$string' /$mvarname/$svarvalue/\n"
+ if $dl;
+ eval "\$$mvarname= \$svarvalue";
+ }
+}
+
+sub checkpkglimit {
+ if (keys %limit_pkgs and not defined $limit_pkgs{$data->{package}}) {
+ print {$transcript} "$gBug number $ref belongs to package $data->{package}, skipping.\n\n";
+ $errors++;
+ return 0;
+ }
+ return 1;
+}
+
+sub manipset {
+ my $list = shift;
+ my $elt = shift;
+ my $add = shift;
+
+ my %h = map { $_ => 1 } split ' ', $list;
+ if ($add) {
+ $h{$elt}=1;
+ }
+ else {
+ delete $h{$elt};
+ }
+ return join ' ', sort keys %h;
+}
+
+# High-level bug manipulation calls
+# Do announcements themselves
+#
+# Possible calling sequences:
+# setbug (returns 0)
+#
+# setbug (returns 1)
+# &transcript(something)
+# nochangebug
+#
+# setbug (returns 1)
+# $action= (something)
+# do {
+# (modify s_* variables)
+# } while (getnextbug);
+
+our $manybugs;
+
+sub nochangebug {
+ &dlen("nochangebug");
+ $state eq 'single' || $state eq 'multiple' || die "$state ?";
+ &cancelbug;
+ &endmerge if $manybugs;
+ $state= 'idle';
+ &dlex("nochangebug");
+}
+
+our $sref;
+our @thisbugmergelist;
+
+sub setbug {
+ &dlen("setbug $ref");
+ if ($ref =~ m/^-\d+/) {
+ if (!defined $clonebugs{$ref}) {
+ ¬foundbug;
+ &dlex("setbug => noclone");
+ return 0;
+ }
+ $ref = $clonebugs{$ref};
+ }
+ $state eq 'idle' || die "$state ?";
+ if (!&getbug) {
+ ¬foundbug;
+ &dlex("setbug => 0s");
+ return 0;
+ }
+
+ if (!&checkpkglimit) {
+ &cancelbug;
+ return 0;
+ }
+
+ @thisbugmergelist= split(/ /,$data->{mergedwith});
+ if (!@thisbugmergelist) {
+ &foundbug;
+ $manybugs= 0;
+ $state= 'single';
+ $sref=$ref;
+ &dlex("setbug => 1s");
+ return 1;
+ }
+ &cancelbug;
+ &getmerge;
+ $manybugs= 1;
+ if (!&getbug) {
+ ¬foundbug;
+ &endmerge;
+ &dlex("setbug => 0mc");
+ return 0;
+ }
+ &foundbug;
+ $state= 'multiple'; $sref=$ref;
+ &dlex("setbug => 1m");
+ return 1;
+}
+
+sub getnextbug {
+ &dlen("getnextbug");
+ $state eq 'single' || $state eq 'multiple' || die "$state ?";
+ &savebug;
+ if (!$manybugs || !@thisbugmergelist) {
+ length($action) || die;
+ print {$transcript} "$action\n$extramessage\n";
+ &endmerge if $manybugs;
+ $state= 'idle';
+ &dlex("getnextbug => 0");
+ return 0;
+ }
+ $ref= shift(@thisbugmergelist);
+ &getbug || die "bug $ref disappeared";
+ &foundbug;
+ &dlex("getnextbug => 1");
+ return 1;
+}
+
+# Low-level bug-manipulation calls
+# Do no announcements
+#
+# getbug (returns 0)
+#
+# getbug (returns 1)
+# cancelbug
+#
+# getmerge
+# $action= (something)
+# getbug (returns 1)
+# savebug/cancelbug
+# getbug (returns 1)
+# savebug/cancelbug
+# [getbug (returns 0)]
+# &transcript("$action\n\n")
+# endmerge
+
+sub notfoundbug { print {$transcript} "$gBug number $ref not found. (Is it archived?)\n\n"; }
+sub foundbug { print {$transcript} "$gBug#$ref: $data->{subject}\n"; }
+
+sub getmerge {
+ &dlen("getmerge");
+ $mergelowstate eq 'idle' || die "$mergelowstate ?";
+ &filelock('lock/merge');
+ $mergelowstate='locked';
+ &dlex("getmerge");
+}
+
+sub endmerge {
+ &dlen("endmerge");
+ $mergelowstate eq 'locked' || die "$mergelowstate ?";
+ &unfilelock;
+ $mergelowstate='idle';
+ &dlex("endmerge");
+}
+
+sub getbug {
+ &dlen("getbug $ref");
+ $lowstate eq 'idle' || die "$state ?";
+ # Only use unmerged bugs here
+ if (($data = &lockreadbug($ref,'db-h'))) {
+ $sref= $ref;
+ $lowstate= "open";
+ &dlex("getbug => 1");
+ $extramessage='';
+ return 1;
+ }
+ $lowstate= 'idle';
+ &dlex("getbug => 0");
+ return 0;
+}
+
+sub cancelbug {
+ &dlen("cancelbug");
+ $lowstate eq 'open' || die "$state ?";
+ &unfilelock;
+ $lowstate= 'idle';
+ &dlex("cancelbug");
+}
+
+sub savebug {
+ &dlen("savebug $ref");
+ $lowstate eq 'open' || die "$lowstate ?";
+ length($action) || die;
+ $ref == $sref || die "read $sref but saving $ref ?";
+ append_action_to_log(bug => $ref,
+ action => $action,
+ requester => $header{from},
+ request_addr => $controlrequestaddr,
+ message => \@log,
+ get_lock => 0,
+ );
+ unlockwritebug($ref, $data);
+ $lowstate= "idle";
+ &dlex("savebug");
+}
+
+sub dlen {
+ return if !$dl;
+ print {$transcript} "C> @_ ($state $lowstate $mergelowstate)\n";
+}
+
+sub dlex {
+ return if !$dl;
+ print {$transcript} "R> @_ ($state $lowstate $mergelowstate)\n";
+}
+
+sub urlsanit {
+ my $url = shift;
+ $url =~ s/%/%25/g;
+ $url =~ s/\+/%2b/g;
+ my %saniarray = ('<','lt', '>','gt', '&','amp', '"','quot');
+ $url =~ s/([<>&"])/\&$saniarray{$1};/g;
+ return $url;
+}
+
+sub sendlynxdoc {
+ &sendlynxdocraw;
+ print {$transcript} "\n";
+ $ok++;
+}
+
+sub sendtxthelp {
+ &sendtxthelpraw;
+ print {$transcript} "\n";
+ $ok++;
+}
+
+
+our $doc;
+sub sendtxthelpraw {
+ my ($relpath,$description) = @_;
+ $doc='';
+ open(D,"$gDocDir/$relpath") || die "open doc file $relpath: $!";
+ while(<D>) { $doc.=$_; }
+ close(D);
+ print {$transcript} "Sending $description in separate message.\n";
+ &sendmailmessage(<<END.$doc,$replyto);
+From: $gMaintainerEmail ($gProject $gBug Tracking System)
+To: $replyto
+Subject: $gProject $gBug help: $description
+References: $header{'message-id'}
+In-Reply-To: $header{'message-id'}
+Message-ID: <handler.s.$nn.help.$midix\@$gEmailDomain>
+Precedence: bulk
+X-$gProject-PR-Message: doc-text $relpath
+
+END
+ $ok++;
+}
+
+sub sendlynxdocraw {
+ my ($relpath,$description) = @_;
+ $doc='';
+ open(L,"lynx -nolist -dump http://$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/) {
+ print {$transcript} "Information ($description) is not available -\n".
+ "perhaps the $gBug does not exist or is not on the WWW yet.\n";
+ $ok++;
+ } elsif ($?) {
+ print {$transcript} "Error getting $description (code $? $!):\n$doc\n";
+ } else {
+ print {$transcript} "Sending $description.\n";
+ &sendmailmessage(<<END.$doc,$replyto);
+From: $gMaintainerEmail ($gProject $gBug Tracking System)
+To: $replyto
+Subject: $gProject $gBugs information: $description
+References: $header{'message-id'}
+In-Reply-To: $header{'message-id'}
+Message-ID: <handler.s.$nn.info.$midix\@$gEmailDomain>
+Precedence: bulk
+X-$gProject-PR-Message: doc-html $relpath
+
+END
+ $ok++;
+ }
+}
+
+
+sub sendinfo {
+ my ($wherefrom,$path,$description) = @_;
+ if ($wherefrom eq "ftp.d.o") {
+ $doc = `lynx -nolist -dump http://ftp.debian.org/debian/indices/$path.gz 2>&1 | gunzip -cf` or die "fork for lynx/gunzip: $!";
+ $! = 0;
+ if ($? == 255 && $doc =~ m/^\n*lynx: Can\'t access start file/) {
+ print {$transcript} "$description is not available.\n";
+ $ok++; return;
+ } elsif ($?) {
+ print {$transcript} "Error getting $description (code $? $!):\n$doc\n";
+ return;
+ }
+ } elsif ($wherefrom eq "local") {
+ open P, "$path";
+ $doc = do { local $/; <P> };
+ close P;
+ } else {
+ print {$transcript} "internal errror: info files location unknown.\n";
+ $ok++; return;
+ }
+ print {$transcript} "Sending $description.\n";
+ &sendmailmessage(<<END.$doc,$replyto);
+From: $gMaintainerEmail ($gProject $gBug Tracking System)
+To: $replyto
+Subject: $gProject $gBugs information: $description
+References: $header{'message-id'}
+In-Reply-To: $header{'message-id'}
+Message-ID: <handler.s.$nn.info.$midix\@$gEmailDomain>
+Precedence: bulk
+X-$gProject-PR-Message: getinfo
+
+$description follows:
+
+END
+ $ok++;
+ print {$transcript} "\n";
+}
+++ /dev/null
-#!/usr/bin/perl
-# $Id: service.in,v 1.118 2005/10/19 01:22:14 don Exp $
-#
-# Usage: service <code>.nn
-# Temps: incoming/P<code>.nn
-
-use File::Copy;
-use MIME::Parser;
-use Debbugs::MIME qw(decode_rfc1522 encode_rfc1522);
-use Debbugs::Mail qw(send_mail_message);
-use Debbugs::User;
-use HTML::Entities qw(encode_entities);
-use Debbugs::Versions::Dpkg;
-
-use Debbugs::Config qw(:globals :config);
-use Debbugs::CGI qw(html_escape);
-use Debbugs::Control qw(:archive :log);
-use Debbugs::Log qw(:misc);
-use Debbugs::Text qw(:templates);
-
-use Mail::RFC822::Address;
-
-$lib_path = $gLibPath;
-require "$lib_path/errorlib";
-$ENV{'PATH'} = $lib_path.':'.$ENV{'PATH'};
-
-chdir("$gSpoolDir") || die "chdir spool: $!\n";
-
-# open(DEBUG,">&4");
-open DEBUG, ">/dev/null";
-$debug = 0;
-umask(002);
-
-$_=shift;
-m/^[RC]\.\d+$/ || &quit("bad argument");
-$control= m/C/;
-$nn= $_;
-if (!rename("incoming/G$nn","incoming/P$nn")) {
- $_=$!.''; m/no such file or directory/i && exit 0;
- &quit("renaming to lock: $!");
-}
-
-open(M,"incoming/P$nn");
-@log=<M>;
-@msg=@log;
-close(M);
-
-chomp @msg;
-
-print "###\n",join("##\n",@msg),"\n###\n" if $debug;
-
-my $parser = new MIME::Parser;
-mkdir "$gSpoolDir/mime.tmp", 0777;
-$parser->output_under("$gSpoolDir/mime.tmp");
-my $entity = eval { $parser->parse_data(join('',@log)) };
-
-# header and decoded body respectively
-my (@headerlines, @bodylines);
-# Bug numbers to send e-mail to, hash so that we don't send to the
-# same bug twice.
-my (%bug_affected);
-
-if ($entity and $entity->head->tags) {
- # Use map instead of chomp to also kill \r.
- @headerlines = map {s/\r?\n?$//; $_;}
- @{$entity->head->header};
-
- my $entity_body = getmailbody($entity);
- @bodylines = map {s/\r?\n$//; $_;}
- $entity_body ? $entity_body->as_lines() : ();
-} else {
- # Legacy pre-MIME code, kept around in case MIME::Parser fails.
- my $i;
- for ($i = 0; $i <= $#msg; $i++) {
- $_ = $msg[$i];
- last unless length($_);
- while ($msg[$i+1] =~ m/^\s/) {
- $i++;
- $_ .= "\n".$msg[$i];
- }
- push @headerlines, $_;
- }
-
- @bodylines = @msg[$i..$#msg];
-}
-
-for (@headerlines) {
- $_ = decode_rfc1522($_);
- s/\n\s/ /g;
- print ">$_<\n" if $debug;
- if (s/^(\S+):\s*//) {
- my $v = lc $1;
- print ">$v=$_<\n" if $debug;
- $header{$v} = $_;
- } else {
- print "!>$_<\n" if $debug;
- }
-}
-
-# Strip off RFC2440-style PGP clearsigning.
-if (@bodylines and $bodylines[0] =~ /^-----BEGIN PGP SIGNED/) {
- shift @bodylines while @bodylines and length $bodylines[0];
- shift @bodylines while @bodylines and $bodylines[0] !~ /\S/;
- for my $findsig (0 .. $#bodylines) {
- if ($bodylines[$findsig] =~ /^-----BEGIN PGP SIGNATURE/) {
- $#bodylines = $findsig - 1;
- last;
- }
- }
- map { s/^- // } @bodylines;
-}
-
-grep(s/\s+$//,@bodylines);
-
-print "***\n",join("\n",@bodylines),"\n***\n" if $debug;
-
-if (defined $header{'resent-from'} && !defined $header{'from'}) {
- $header{'from'} = $header{'resent-from'};
-}
-
-defined($header{'from'}) || &quit("no From header");
-
-delete $header{'reply-to'}
- if ( defined($header{'reply-to'}) && $header{'reply-to'} =~ m/^\s*$/ );
-
-if ( defined($header{'reply-to'}) && $header{'reply-to'} ne "" ) {
- $replyto = $header{'reply-to'};
-} else {
- $replyto = $header{'from'};
-}
-
-# This is an error counter which should be incremented every time there is an error.
-my $errors = 0;
-$controlrequestaddr= $control ? "control\@$gEmailDomain" : "request\@$gEmailDomain";
-$transcript='';
-&transcript("Processing commands for $controlrequestaddr:\n\n");
-
-$dl= 0;
-$state= 'idle';
-$lowstate= 'idle';
-$mergelowstate= 'idle';
-$midix=0;
-$extras="";
-
-my $user = $replyto;
-$user =~ s/,.*//;
-$user =~ s/^.*<(.*)>.*$/$1/;
-$user =~ s/[(].*[)]//;
-$user =~ s/^\s*(\S+)\s+.*$/$1/;
-$user = "" unless (Debbugs::User::is_valid_user($user));
-my $indicated_user = 0;
-
-my $quickabort = 0;
-
-my $fuckheads = "(" . join("|", @gExcludeFromControl) . ")";
-if (@gExcludeFromControl and $replyto =~ m/$fuckheads/) {
- &transcript(fill_template('mail/excluded_from_control'));
- $quickabort = 1;
-}
-
-my %limit_pkgs = ();
-my %clonebugs = ();
-my @bcc = ();
-
-sub addbcc {
- push @bcc, $_[0] unless grep { $_ eq $_[0] } @bcc;
-}
-
-for ($procline=0; $procline<=$#bodylines; $procline++) {
- $state eq 'idle' || print "$state ?\n";
- $lowstate eq 'idle' || print "$lowstate ?\n";
- $mergelowstate eq 'idle' || print "$mergelowstate ?\n";
- if ($quickabort) {
- &transcript("Stopping processing here.\n\n");
- last;
- }
- $_= $bodylines[$procline]; s/\s+$//;
- next unless m/\S/;
- &transcript("> $_\n");
- next if m/^\s*\#/;
- $action= '';
- if (m/^stop\s*$/i || m/^quit\s*$/i || m/^--\s*$/ || m/^thank(?:s|\s*you)?\s*$/i || m/^kthxbye\s*$/i) {
- &transcript("Stopping processing here.\n\n");
- last;
- } elsif (m/^debug\s+(\d+)$/i && $1 >= 0 && $1 <= 1000) {
- $dl= $1+0;
- &transcript("Debug level $dl.\n\n");
- } elsif (m/^(send|get)\s+\#?(\d{2,})$/i) {
- $ref= $2+0;
- &sendlynxdoc("bugreport.cgi?bug=$ref","logs for $gBug#$ref");
- } elsif (m/^send-detail\s+\#?(\d{2,})$/i) {
- $ref= $1+0;
- &sendlynxdoc("bugreport.cgi?bug=$ref&boring=yes",
- "detailed logs for $gBug#$ref");
- } elsif (m/^index(\s+full)?$/i) {
- &transcript("This BTS function is currently disabled, sorry.\n\n");
- $errors++;
- $ok++; # well, it's not really ok, but it fixes #81224 :)
- } elsif (m/^index-summary\s+by-package$/i) {
- &transcript("This BTS function is currently disabled, sorry.\n\n");
- $errors++;
- $ok++; # well, it's not really ok, but it fixes #81224 :)
- } elsif (m/^index-summary(\s+by-number)?$/i) {
- &transcript("This BTS function is currently disabled, sorry.\n\n");
- $errors++;
- $ok++; # well, it's not really ok, but it fixes #81224 :)
- } elsif (m/^index(\s+|-)pack(age)?s?$/i) {
- &sendlynxdoc("pkgindex.cgi?indexon=pkg",'index of packages');
- } elsif (m/^index(\s+|-)maints?$/i) {
- &sendlynxdoc("pkgindex.cgi?indexon=maint",'index of maintainers');
- } elsif (m/^index(\s+|-)maint\s+(\S+)$/i) {
- $maint = $2;
- &sendlynxdoc("pkgreport.cgi?maint=" . urlsanit($maint),
- "$gBug list for maintainer \`$maint'");
- $ok++;
- } elsif (m/^index(\s+|-)pack(age)?s?\s+(\S.*\S)$/i) {
- $package = $+;
- &sendlynxdoc("pkgreport.cgi?pkg=" . urlsanit($package),
- "$gBug list for package $package");
- $ok++;
- } elsif (m/^send-unmatched(\s+this|\s+-?0)?$/i) {
- &transcript("This BTS function is currently disabled, sorry.\n\n");
- $errors++;
- $ok++; # well, it's not really ok, but it fixes #81224 :)
- } elsif (m/^send-unmatched\s+(last|-1)$/i) {
- &transcript("This BTS function is currently disabled, sorry.\n\n");
- $errors++;
- $ok++; # well, it's not really ok, but it fixes #81224 :)
- } elsif (m/^send-unmatched\s+(old|-2)$/i) {
- &transcript("This BTS function is currently disabled, sorry.\n\n");
- $errors++;
- $ok++; # well, it's not really ok, but it fixes #81224 :)
- } elsif (m/^getinfo\s+([\w-.]+)$/i) {
- # the following is basically a Debian-specific kludge, but who cares
- $req = $1;
- if ($req =~ /^maintainers$/i && -f "$gConfigDir/Maintainers") {
- &sendinfo("local", "$gConfigDir/Maintainers", "Maintainers file");
- } elsif ($req =~ /^override\.(\w+)\.([\w-.]+)$/i) {
- $req =~ s/.gz$//;
- &sendinfo("ftp.d.o", "$req", "override file for $2 part of $1 distribution");
- } elsif ($req =~ /^pseudo-packages\.(description|maintainers)$/i && -f "$gConfigDir/$req") {
- &sendinfo("local", "$gConfigDir/$req", "$req file");
- } else {
- &transcript("Info file $req does not exist.\n\n");
- }
- } elsif (m/^help/i) {
- &sendhelp;
- &transcript("\n");
- $ok++;
- } elsif (m/^refcard/i) {
- &sendtxthelp("bug-mailserver-refcard.txt","mail servers' reference card");
- } elsif (m/^subscribe/i) {
- &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
-to send them to you.
-soon: MAILINGLISTS_TEXT
-END
- } elsif (m/^unsubscribe/i) {
- &transcript(<<END);
-soon: UNSUBSCRIBE_TEXT
-soon: MAILINGLISTS_TEXT
-END
- } elsif (m/^user\s+(\S+)\s*$/i) {
- my $newuser = $1;
- if (Debbugs::User::is_valid_user($newuser)) {
- my $olduser = ($user ne "" ? " (was $user)" : "");
- &transcript("Setting user to $newuser$olduser.\n");
- $user = $newuser;
- $indicated_user = 1;
- } else {
- &transcript("Selected user id ($newuser) invalid, sorry\n");
- $errors++;
- $user = "";
- $indicated_user = 1;
- }
- } elsif (m/^usercategory\s+(\S+)(\s+\[hidden\])?\s*$/i) {
- $ok++;
- my $catname = $1;
- my $hidden = ($2 ne "");
-
- my $prefix = "";
- my @cats;
- my $bad = 0;
- my $catsec = 0;
- if ($user eq "") {
- &transcript("No valid user selected\n");
- $errors++;
- next;
- }
- if (not $indicated_user and defined $user) {
- &transcript("User is $user\n");
- $indicated_user = 1;
- }
- while (++$procline <= $#bodylines) {
- unless ($bodylines[$procline] =~ m/^\s*([*+])\s*(\S.*)$/) {
- $procline--;
- last;
- }
- &transcript("> $bodylines[$procline]\n");
- next if $bad;
- my ($o, $txt) = ($1, $2);
- if ($#cats == -1 && $o eq "+") {
- &transcript("User defined category specification must start with a category name. Skipping.\n\n");
- $errors++;
- $bad = 1;
- next;
- }
- if ($o eq "+") {
- unless (ref($cats[-1]) eq "HASH") {
- $cats[-1] = { "nam" => $cats[-1],
- "pri" => [], "ttl" => [] };
- }
- $catsec++;
- my ($desc, $ord, $op);
- if ($txt =~ m/^(.*\S)\s*\[((\d+):\s*)?\]\s*$/) {
- $desc = $1; $ord = $3; $op = "";
- } elsif ($txt =~ m/^(.*\S)\s*\[((\d+):\s*)?(\S+)\]\s*$/) {
- $desc = $1; $ord = $3; $op = $4;
- } elsif ($txt =~ m/^([^[\s]+)\s*$/) {
- $desc = ""; $op = $1;
- } else {
- &transcript("Unrecognised syntax for category section. Skipping.\n\n");
- $errors++;
- $bad = 1;
- next;
- }
- $ord = 999 unless defined $ord;
-
- if ($op) {
- push @{$cats[-1]->{"pri"}}, $prefix . $op;
- push @{$cats[-1]->{"ttl"}}, $desc;
- push @ords, "$ord $catsec";
- } else {
- @cats[-1]->{"def"} = $desc;
- push @ords, "$ord DEF";
- $catsec--;
- }
- @ords = sort { my ($a1, $a2, $b1, $b2) = split / /, "$a $b";
- $a1 <=> $b1 || $a2 <=> $b2; } @ords;
- $cats[-1]->{"ord"} = [map { m/^.* (\S+)/; $1 eq "DEF" ? $catsec + 1 : $1 } @ords];
- } elsif ($o eq "*") {
- $catsec = 0;
- my ($name);
- if ($txt =~ m/^(.*\S)(\s*\[(\S+)\])\s*$/) {
- $name = $1; $prefix = $3;
- } else {
- $name = $txt; $prefix = "";
- }
- push @cats, $name;
- }
- }
- # XXX: got @cats, now do something with it
- my $u = Debbugs::User::get_user($user);
- if (@cats) {
- &transcript("Added usercategory $catname.\n\n");
- $u->{"categories"}->{$catname} = [ @cats ];
- if (not $hidden) {
- push @{$u->{visible_cats}},$catname;
- }
- } else {
- &transcript("Removed usercategory $catname.\n\n");
- delete $u->{"categories"}->{$catname};
- @{$u->{visible_cats}} = grep {$_ ne $catname} @{$u->{visible_cats}};
- }
- $u->write();
- } elsif (m/^usertags?\s+\#?(-?\d+)\s+(([=+-])\s*)?(\S.*)?$/i) {
- $ok++;
- $ref = $1; $addsubcode = $3 || "+"; $tags = $4;
- if ($ref =~ m/^-\d+$/ && defined $clonebugs{$ref}) {
- $ref = $clonebugs{$ref};
- }
- if ($user eq "") {
- &transcript("No valid user selected\n");
- $errors++;
- $indicated_user = 1;
- } elsif (&setbug) {
- if (not $indicated_user and defined $user) {
- &transcript("User is $user\n");
- $indicated_user = 1;
- }
- &nochangebug;
- my %ut;
- Debbugs::User::read_usertags(\%ut, $user);
- my @oldtags = (); my @newtags = (); my @badtags = ();
- my %chtags;
- for my $t (split /[,\s]+/, $tags) {
- if ($t =~ m/^[a-zA-Z0-9.+\@-]+$/) {
- $chtags{$t} = 1;
- } else {
- push @badtags, $t;
- }
- }
- if (@badtags) {
- &transcript("Ignoring illegal tag/s: ".join(', ', @badtags).".\nPlease use only alphanumerics, at, dot, plus and dash.\n");
- $errors++;
- }
- for my $t (keys %chtags) {
- $ut{$t} = [] unless defined $ut{$t};
- }
- for my $t (keys %ut) {
- my %res = map { ($_, 1) } @{$ut{$t}};
- push @oldtags, $t if defined $res{$ref};
- my $addop = ($addsubcode eq "+" or $addsubcode eq "=");
- my $del = (defined $chtags{$t} ? $addsubcode eq "-"
- : $addsubcode eq "=");
- $res{$ref} = 1 if ($addop && defined $chtags{$t});
- delete $res{$ref} if ($del);
- push @newtags, $t if defined $res{$ref};
- $ut{$t} = [ sort { $a <=> $b } (keys %res) ];
- }
- if (@oldtags == 0) {
- &transcript("There were no usertags set.\n");
- } else {
- &transcript("Usertags were: " . join(" ", @oldtags) . ".\n");
- }
- &transcript("Usertags are now: " . join(" ", @newtags) . ".\n");
- Debbugs::User::write_usertags(\%ut, $user);
- }
- } elsif (!$control) {
- &transcript(<<END);
-Unknown command or malformed arguments to command.
-(Use control\@$gEmailDomain to manipulate reports.)
-
-END
- $errors++;
- if (++$unknowns >= 3) {
- &transcript("Too many unknown commands, stopping here.\n\n");
- last;
- }
-#### "developer only" ones start here
- } elsif (m/^close\s+\#?(-?\d+)(?:\s+(\d.*))?$/i) {
- $ok++;
- $ref= $1;
- $bug_affected{$ref}=1;
- $version= $2;
- if (&setbug) {
- &transcript("'close' is deprecated; see http://$gWebDomain/Developer$gHTMLSuffix#closing.\n");
- if (length($data->{done}) and not defined($version)) {
- &transcript("$gBug is already closed, cannot re-close.\n\n");
- &nochangebug;
- } else {
- $action= "$gBug " .
- (defined($version) ?
- "marked as fixed in version $version" :
- "closed") .
- ", send any further explanations to $data->{originator}";
- do {
- &addmaintainers($data);
- if ( length( $gDoneList ) > 0 && length( $gListDomain ) >
- 0 ) { &addccaddress("$gDoneList\@$gListDomain"); }
- $data->{done}= $replyto;
- my @keywords= split ' ', $data->{keywords};
- if (grep $_ eq 'pending', @keywords) {
- $extramessage= "Removed pending tag.\n";
- $data->{keywords}= join ' ', grep $_ ne 'pending',
- @keywords;
- }
- addfixedversions($data, $data->{package}, $version, 'binary');
-
- $message= <<END;
-From: $gMaintainerEmail ($gProject $gBug Tracking System)
-To: $data->{originator}
-Subject: $gBug#$ref acknowledged by developer
- ($header{'subject'})
-References: $header{'message-id'} $data->{msgid}
-In-Reply-To: $data->{msgid}
-Message-ID: <handler.$ref.$nn.notifdonectrl.$midix\@$gEmailDomain>
-Reply-To: $ref\@$gEmailDomain
-X-$gProject-PR-Message: they-closed-control $ref
-
-This is an automatic notification regarding your $gBug report
-#$ref: $data->{subject},
-which was filed against the $data->{package} package.
-
-It has been marked as closed by one of the developers, namely
-$replyto.
-
-You should be hearing from them with a substantive response shortly,
-in case you haven't already. If not, please contact them directly.
-
-$gMaintainer
-(administrator, $gProject $gBugs database)
-
-END
- &sendmailmessage($message,$data->{originator});
- } while (&getnextbug);
- }
- }
- } elsif (m/^reassign\s+\#?(-?\d+)\s+(\S+)(?:\s+(\d.*))?$/i) {
- $ok++;
- $ref= $1; $newpackage= $2;
- $bug_affected{$ref}=1;
- $version= $3;
- $newpackage =~ y/A-Z/a-z/;
- if (&setbug) {
- if (length($data->{package})) {
- $action= "$gBug reassigned from package \`$data->{package}'".
- " to \`$newpackage'.";
- } else {
- $action= "$gBug assigned to package \`$newpackage'.";
- }
- do {
- &addmaintainers($data);
- $data->{package}= $newpackage;
- $data->{found_versions}= [];
- $data->{fixed_versions}= [];
- # TODO: what if $newpackage is a source package?
- addfoundversions($data, $data->{package}, $version, 'binary');
- &addmaintainers($data);
- } while (&getnextbug);
- }
- } elsif (m/^reopen\s+\#?(-?\d+)$/i ? ($noriginator='', 1) :
- m/^reopen\s+\#?(-?\d+)\s+\=$/i ? ($noriginator='', 1) :
- m/^reopen\s+\#?(-?\d+)\s+\!$/i ? ($noriginator=$replyto, 1) :
- m/^reopen\s+\#?(-?\d+)\s+(\S.*\S)$/i ? ($noriginator=$2, 1) : 0) {
- $ok++;
- $ref= $1;
- $bug_affected{$ref}=1;
- if (&setbug) {
- if (@{$data->{fixed_versions}}) {
- &transcript("'reopen' may be inappropriate when a bug has been closed with a version;\nyou may need to use 'found' to remove fixed versions.\n");
- }
- if (!length($data->{done})) {
- &transcript("$gBug is already open, cannot reopen.\n\n");
- &nochangebug;
- } else {
- $action=
- $noriginator eq '' ? "$gBug reopened, originator not changed." :
- "$gBug reopened, originator set to $noriginator.";
- do {
- &addmaintainers($data);
- $data->{originator}= $noriginator eq '' ? $data->{originator} : $noriginator;
- $data->{fixed_versions}= [];
- $data->{done}= '';
- } while (&getnextbug);
- }
- }
- } elsif (m{^found\s+\#?(-?\d+)
- (?:\s+((?:$config{package_name_re}\/)?
- $config{package_version_re}))?$}ix) {
- $ok++;
- $ref= $1;
- $version= $2;
- if (&setbug) {
- if (!length($data->{done}) and not defined($version)) {
- &transcript("$gBug is already open, cannot reopen.\n\n");
- $errors++;
- &nochangebug;
- } else {
- $action=
- defined($version) ?
- "$gBug marked as found in version $version." :
- "$gBug reopened.";
- do {
- &addmaintainers($data);
- # The 'done' field gets a bit weird with version
- # tracking, because a bug may be closed by multiple
- # people in different branches. Until we have something
- # more flexible, we set it every time a bug is fixed,
- # and clear it when a bug is found in a version greater
- # than any version in which the bug is fixed or when
- # a bug is found and there is no fixed version
- if (defined $version) {
- my ($version_only) = $version =~ m{([^/]+)$};
- addfoundversions($data, $data->{package}, $version, 'binary');
- my @fixed_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
- map {s{.+/}{}; $_;} @{$data->{fixed_versions}};
- if (not @fixed_order or (Debbugs::Versions::Dpkg::vercmp($version_only,$fixed_order[-1]) >= 0)) {
- $action = "$gBug marked as found in version $version and reopened."
- if length $data->{done};
- $data->{done} = '';
- }
- } else {
- # Versionless found; assume old-style "not fixed at
- # all".
- $data->{fixed_versions} = [];
- $data->{done} = '';
- }
- } while (&getnextbug);
- }
- }
- } elsif (m[^notfound\s+\#?(-?\d+)\s+
- ((?:$config{package_name_re}\/)?
- \S+)\s*$]ix) {
- $ok++;
- $ref= $1;
- $version= $2;
- if (&setbug) {
- $action= "$gBug no longer marked as found in version $version.";
- if (length($data->{done})) {
- $extramessage= "(By the way, this $gBug is currently marked as done.)\n";
- }
- do {
- &addmaintainers($data);
- removefoundversions($data, $data->{package}, $version, 'binary');
- } while (&getnextbug);
- }
- }
- elsif (m[^fixed\s+\#?(-?\d+)\s+
- ((?:$config{package_name_re}\/)?
- $config{package_version_re})\s*$]ix) {
- $ok++;
- $ref= $1;
- $version= $2;
- if (&setbug) {
- $action=
- defined($version) ?
- "$gBug marked as fixed in version $version." :
- "$gBug reopened.";
- do {
- &addmaintainers($data);
- addfixedversions($data, $data->{package}, $version, 'binary');
- } while (&getnextbug);
- }
- }
- elsif (m[^notfixed\s+\#?(-?\d+)\s+
- ((?:$config{package_name_re}\/)?
- \S+)\s*$]ix) {
- $ok++;
- $ref= $1;
- $version= $2;
- if (&setbug) {
- $action=
- defined($version) ?
- "$gBug no longer marked as fixed in version $version." :
- "$gBug reopened.";
- do {
- &addmaintainers($data);
- removefixedversions($data, $data->{package}, $version, 'binary');
- } while (&getnextbug);
- }
- }
- elsif (m/^submitter\s+\#?(-?\d+)\s+\!$/i ? ($newsubmitter=$replyto, 1) :
- m/^submitter\s+\#?(-?\d+)\s+(\S.*\S)$/i ? ($newsubmitter=$2, 1) : 0) {
- $ok++;
- $ref= $1;
- $bug_affected{$ref}=1;
- if ($ref =~ m/^-\d+$/ && defined $clonebugs{$ref}) {
- $ref = $clonebugs{$ref};
- }
- if (not Mail::RFC822::Address::valid($newsubmitter)) {
- transcript("$newsubmitter is not a valid e-mail address; not changing submitter\n");
- $errors++;
- }
- elsif (&getbug) {
- if (&checkpkglimit) {
- &foundbug;
- &addmaintainers($data);
- $oldsubmitter= $data->{originator};
- $data->{originator}= $newsubmitter;
- $action= "Changed $gBug submitter from $oldsubmitter to $newsubmitter.";
- &savebug;
- &transcript("$action\n");
- if (length($data->{done})) {
- &transcript("(By the way, that $gBug is currently marked as done.)\n");
- }
- &transcript("\n");
- $message= <<END;
-From: $gMaintainerEmail ($gProject $gBug Tracking System)
-To: $oldsubmitter
-Subject: $gBug#$ref submitter address changed
- ($header{'subject'})
-References: $header{'message-id'} $data->{msgid}
-In-Reply-To: $data->{msgid}
-Message-ID: <handler.$ref.$nn.newsubmitter.$midix\@$gEmailDomain>
-Reply-To: $ref\@$gEmailDomain
-X-$gProject-PR-Message: submitter-changed $ref
-
-The submitter address recorded for your $gBug report
-#$ref: $data->{subject}
-has been changed.
-
-The old submitter address for this report was
-$oldsubmitter.
-The new submitter address is
-$newsubmitter.
-
-This change was made by
-$replyto.
-If it was incorrect, please contact them directly.
-
-$gMaintainer
-(administrator, $gProject $gBugs database)
-
-END
- &sendmailmessage($message,$oldsubmitter);
- } else {
- &cancelbug;
- }
- } else {
- ¬foundbug;
- }
- } elsif (m/^forwarded\s+\#?(-?\d+)\s+(\S.*\S)$/i) {
- $ok++;
- $ref= $1; $whereto= $2;
- $bug_affected{$ref}=1;
- if (&setbug) {
- if (length($data->{forwarded})) {
- $action= "Forwarded-to-address changed from $data->{forwarded} to $whereto.";
- } else {
- $action= "Noted your statement that $gBug has been forwarded to $whereto.";
- }
- if (length($data->{done})) {
- $extramessage= "(By the way, this $gBug is currently marked as done.)\n";
- }
- do {
- &addmaintainers($data);
- if (length($gForwardList)>0 && length($gListDomain)>0 ) {
- &addccaddress("$gForwardList\@$gListDomain");
- }
- $data->{forwarded}= $whereto;
- } while (&getnextbug);
- }
- } elsif (m/^notforwarded\s+\#?(-?\d+)$/i) {
- $ok++;
- $ref= $1;
- $bug_affected{$ref}=1;
- if (&setbug) {
- if (!length($data->{forwarded})) {
- &transcript("$gBug is not marked as having been forwarded.\n\n");
- &nochangebug;
- } else {
- $action= "Removed annotation that $gBug had been forwarded to $data->{forwarded}.";
- do {
- &addmaintainers($data);
- $data->{forwarded}= '';
- } while (&getnextbug);
- }
- }
- } elsif (m/^severity\s+\#?(-?\d+)\s+([-0-9a-z]+)$/i ||
- m/^priority\s+\#?(-?\d+)\s+([-0-9a-z]+)$/i) {
- $ok++;
- $ref= $1;
- $bug_affected{$ref}=1;
- $newseverity= $2;
- if (!grep($_ eq $newseverity, @gSeverityList, "$gDefaultSeverity")) {
- &transcript("Severity level \`$newseverity' is not known.\n".
- "Recognized are: $gShowSeverities.\n\n");
- $errors++;
- } elsif (exists $gObsoleteSeverities{$newseverity}) {
- &transcript("Severity level \`$newseverity' is obsolete. " .
- "Use $gObsoleteSeverities{$newseverity} instead.\n\n");
- $errors++;
- } elsif (&setbug) {
- $printseverity= $data->{severity};
- $printseverity= "$gDefaultSeverity" if $printseverity eq '';
- $action= "Severity set to \`$newseverity' from \`$printseverity'";
- do {
- &addmaintainers($data);
- if (defined $gStrongList and isstrongseverity($newseverity)) {
- addbcc("$gStrongList\@$gListDomain");
- }
- $data->{severity}= $newseverity;
- } while (&getnextbug);
- }
- } elsif (m/^tags?\s+\#?(-?\d+)\s+(([=+-])\s*)?(\S.*)?$/i) {
- $ok++;
- $ref = $1; $addsubcode = $3; $tags = $4;
- $bug_affected{$ref}=1;
- $addsub = "add";
- if (defined $addsubcode) {
- $addsub = "sub" if ($addsubcode eq "-");
- $addsub = "add" if ($addsubcode eq "+");
- $addsub = "set" if ($addsubcode eq "=");
- }
- my @okaytags = ();
- my @badtags = ();
- foreach my $t (split /[\s,]+/, $tags) {
- if (!grep($_ eq $t, @gTags)) {
- push @badtags, $t;
- } else {
- push @okaytags, $t;
- }
- }
- if (@badtags) {
- &transcript("Unknown tag/s: ".join(', ', @badtags).".\n".
- "Recognized are: ".join(' ', @gTags).".\n\n");
- $errors++;
- }
- if (&setbug) {
- if ($data->{keywords} eq '') {
- &transcript("There were no tags set.\n");
- } else {
- &transcript("Tags were: $data->{keywords}\n");
- }
- if ($addsub eq "set") {
- $action= "Tags set to: " . join(", ", @okaytags);
- } elsif ($addsub eq "add") {
- $action= "Tags added: " . join(", ", @okaytags);
- } elsif ($addsub eq "sub") {
- $action= "Tags removed: " . join(", ", @okaytags);
- }
- do {
- &addmaintainers($data);
- $data->{keywords} = '' if ($addsub eq "set");
- # Allow removing obsolete tags.
- if ($addsub eq "sub") {
- foreach my $t (@badtags) {
- $data->{keywords} = join ' ', grep $_ ne $t,
- split ' ', $data->{keywords};
- }
- }
- # Now process all other additions and subtractions.
- foreach my $t (@okaytags) {
- $data->{keywords} = join ' ', grep $_ ne $t,
- split ' ', $data->{keywords};
- $data->{keywords} = "$t $data->{keywords}" unless($addsub eq "sub");
- }
- $data->{keywords} =~ s/\s*$//;
- } while (&getnextbug);
- }
- } elsif (m/^(un)?block\s+\#?(-?\d+)\s+(by|with)\s+(\S.*)?$/i) {
- $ok++;
- my $bugnum = $2; my $blockers = $4;
- $addsub = "add";
- $addsub = "sub" if ($1 eq "un");
- if ($bugnum =~ m/^-\d+$/ && defined $clonebugs{$bugnum}) {
- $bugnum = $clonebugs{$bugnum};
- }
-
- my @okayblockers;
- my @badblockers;
- foreach my $b (split /[\s,]+/, $blockers) {
- $b=~s/^\#//;
- if ($b=~/[0-9]+/) {
- $ref=$b;
- if ($ref =~ m/^-\d+$/ && defined $clonebugs{$ref}) {
- $ref = $clonebugs{$ref};
- }
- if (&getbug) {
- &foundbug;
- push @okayblockers, $ref;
-
- # add to the list all bugs that are merged with $b,
- # because all of their data must be kept in sync
- @thisbugmergelist= split(/ /,$data->{mergedwith});
- &cancelbug;
-
- foreach $ref (@thisbugmergelist) {
- if (&getbug) {
- push @okayblockers, $ref;
- &cancelbug;
- }
- }
- }
- else {
- ¬foundbug;
- push @badblockers, $ref;
- }
- }
- else {
- push @badblockers, $b;
- }
- }
- if (@badblockers) {
- &transcript("Unknown blocking bug/s: ".join(', ', @badblockers).".\n");
- $errors++;
- }
-
- $ref=$bugnum;
- if (&setbug) {
- if ($data->{blockedby} eq '') {
- &transcript("Was not blocked by any bugs.\n");
- } else {
- &transcript("Was blocked by: $data->{blockedby}\n");
- }
- if ($addsub eq "set") {
- $action= "Blocking bugs of $bugnum set to: " . join(", ", @okayblockers);
- } elsif ($addsub eq "add") {
- $action= "Blocking bugs of $bugnum added: " . join(", ", @okayblockers);
- } elsif ($addsub eq "sub") {
- $action= "Blocking bugs of $bugnum removed: " . join(", ", @okayblockers);
- }
- my %removedblocks;
- my %addedblocks;
- do {
- &addmaintainers($data);
- my @oldblockerlist = split ' ', $data->{blockedby};
- $data->{blockedby} = '' if ($addsub eq "set");
- foreach my $b (@okayblockers) {
- $data->{blockedby} = manipset($data->{blockedby}, $b,
- ($addsub ne "sub"));
- }
-
- foreach my $b (@oldblockerlist) {
- if (! grep { $_ eq $b } split ' ', $data->{blockedby}) {
- push @{$removedblocks{$b}}, $ref;
- }
- }
- foreach my $b (split ' ', $data->{blockedby}) {
- if (! grep { $_ eq $b } @oldblockerlist) {
- push @{$addedblocks{$b}}, $ref;
- }
- }
- } while (&getnextbug);
-
- # Now that the blockedby data is updated, change blocks data
- # to match the changes.
- foreach $ref (keys %addedblocks) {
- if (&getbug) {
- foreach my $b (@{$addedblocks{$ref}}) {
- $data->{blocks} = manipset($data->{blocks}, $b, 1);
- }
- &savebug;
- }
- }
- foreach $ref (keys %removedblocks) {
- if (&getbug) {
- foreach my $b (@{$removedblocks{$ref}}) {
- $data->{blocks} = manipset($data->{blocks}, $b, 0);
- }
- &savebug;
- }
- }
- }
- } elsif (m/^retitle\s+\#?(-?\d+)\s+(\S.*\S)\s*$/i) {
- $ok++;
- $ref= $1; $newtitle= $2;
- $bug_affected{$ref}=1;
- if ($ref =~ m/^-\d+$/ && defined $clonebugs{$ref}) {
- $ref = $clonebugs{$ref};
- }
- if (&getbug) {
- if (&checkpkglimit) {
- &foundbug;
- &addmaintainers($data);
- my $oldtitle = $data->{subject};
- $data->{subject}= $newtitle;
- $action= "Changed $gBug title to `$newtitle' from `$oldtitle'.";
- &savebug;
- &transcript("$action\n");
- if (length($data->{done})) {
- &transcript("(By the way, that $gBug is currently marked as done.)\n");
- }
- &transcript("\n");
- } else {
- &cancelbug;
- }
- } else {
- ¬foundbug;
- }
- } elsif (m/^unmerge\s+\#?(-?\d+)$/i) {
- $ok++;
- $ref= $1;
- $bug_affected{$ref} = 1;
- if (&setbug) {
- if (!length($data->{mergedwith})) {
- &transcript("$gBug is not marked as being merged with any others.\n\n");
- &nochangebug;
- } else {
- $mergelowstate eq 'locked' || die "$mergelowstate ?";
- $action= "Disconnected #$ref from all other report(s).";
- @newmergelist= split(/ /,$data->{mergedwith});
- $discref= $ref;
- @bug_affected{@newmergelist} = 1 x @newmergelist;
- do {
- &addmaintainers($data);
- $data->{mergedwith}= ($ref == $discref) ? ''
- : join(' ',grep($_ ne $ref,@newmergelist));
- } while (&getnextbug);
- }
- }
- } elsif (m/^merge\s+#?(-?\d+(\s+#?-?\d+)+)\s*$/i) {
- $ok++;
- my @tomerge= sort { $a <=> $b } split(/\s+#?/,$1);
- my @newmergelist= ();
- my %tags = ();
- my %found = ();
- my %fixed = ();
- &getmerge;
- while (defined($ref= shift(@tomerge))) {
- &transcript("D| checking merge $ref\n") if $dl;
- $ref+= 0;
- if ($ref =~ m/^-\d+$/ && defined $clonebugs{$ref}) {
- $ref = $clonebugs{$ref};
- }
- next if grep($_ == $ref,@newmergelist);
- if (!&getbug) { ¬foundbug; @newmergelist=(); last }
- if (!&checkpkglimit) { &cancelbug; @newmergelist=(); last; }
- &foundbug;
- &transcript("D| adding $ref ($data->{mergedwith})\n") if $dl;
- $mismatch= '';
- &checkmatch('package','m_package',$data->{package},@newmergelist);
- &checkmatch('forwarded addr','m_forwarded',$data->{forwarded},@newmergelist);
- $data->{severity} = '$gDefaultSeverity' if $data->{severity} eq '';
- &checkmatch('severity','m_severity',$data->{severity},@newmergelist);
- &checkmatch('blocks','m_blocks',$data->{blocks},@newmergelist);
- &checkmatch('blocked-by','m_blockedby',$data->{blockedby},@newmergelist);
- &checkmatch('done mark','m_done',length($data->{done}) ? 'done' : 'open',@newmergelist);
- &checkmatch('owner','m_owner',$data->{owner},@newmergelist);
- foreach my $t (split /\s+/, $data->{keywords}) { $tags{$t} = 1; }
- foreach my $f (@{$data->{found_versions}}) { $found{$f} = 1; }
- foreach my $f (@{$data->{fixed_versions}}) { $fixed{$f} = 1; }
- if (length($mismatch)) {
- &transcript("Mismatch - only $gBugs in same state can be merged:\n".
- $mismatch."\n");
- $errors++;
- &cancelbug; @newmergelist=(); last;
- }
- push(@newmergelist,$ref);
- push(@tomerge,split(/ /,$data->{mergedwith}));
- &cancelbug;
- }
- if (@newmergelist) {
- @newmergelist= sort { $a <=> $b } @newmergelist;
- $action= "Merged @newmergelist.";
- delete @fixed{keys %found};
- for $ref (@newmergelist) {
- &getbug || die "huh ? $gBug $ref disappeared during merge";
- &addmaintainers($data);
- @bug_affected{@newmergelist} = 1 x @newmergelist;
- $data->{mergedwith}= join(' ',grep($_ != $ref,@newmergelist));
- $data->{keywords}= join(' ', keys %tags);
- $data->{found_versions}= [sort keys %found];
- $data->{fixed_versions}= [sort keys %fixed];
- &savebug;
- }
- &transcript("$action\n\n");
- }
- &endmerge;
- } elsif (m/^forcemerge\s+\#?(-?\d+(?:\s+\#?-?\d+)+)\s*$/i) {
- $ok++;
- my @temp = split /\s+\#?/,$1;
- my $master_bug = shift @temp;
- my $master_bug_data;
- my @tomerge = sort { $a <=> $b } @temp;
- unshift @tomerge,$master_bug;
- &transcript("D| force merging ".join(',',@tomerge)."\n") if $dl;
- my @newmergelist= ();
- my %tags = ();
- my %found = ();
- my %fixed = ();
- # Here we try to do the right thing.
- # First, if the bugs are in the same package, we merge all of the found, fixed, and tags.
- # If not, we discard the found and fixed.
- # Everything else we set to the values of the first bug.
- &getmerge;
- while (defined($ref= shift(@tomerge))) {
- &transcript("D| checking merge $ref\n") if $dl;
- $ref+= 0;
- if ($ref =~ m/^-\d+$/ && defined $clonebugs{$ref}) {
- $ref = $clonebugs{$ref};
- }
- next if grep($_ == $ref,@newmergelist);
- if (!&getbug) { ¬foundbug; @newmergelist=(); last }
- if (!&checkpkglimit) { &cancelbug; @newmergelist=(); last; }
- &foundbug;
- &transcript("D| adding $ref ($data->{mergedwith})\n") if $dl;
- $master_bug_data = $data if not defined $master_bug_data;
- if ($data->{package} ne $master_bug_data->{package}) {
- &transcript("Mismatch - only $gBugs in the same package can be forcibly merged:\n".
- "$gBug $ref is not in the same package as $master_bug\n");
- $errors++;
- &cancelbug; @newmergelist=(); last;
- }
- for my $t (split /\s+/,$data->{keywords}) {
- $tags{$t} = 1;
- }
- @found{@{$data->{found_versions}}} = (1) x @{$data->{found_versions}};
- @fixed{@{$data->{fixed_versions}}} = (1) x @{$data->{fixed_versions}};
- push(@newmergelist,$ref);
- push(@tomerge,split(/ /,$data->{mergedwith}));
- &cancelbug;
- }
- if (@newmergelist) {
- @newmergelist= sort { $a <=> $b } @newmergelist;
- $action= "Forcibly Merged @newmergelist.";
- delete @fixed{keys %found};
- for $ref (@newmergelist) {
- &getbug || die "huh ? $gBug $ref disappeared during merge";
- &addmaintainers($data);
- @bug_affected{@newmergelist} = 1 x @newmergelist;
- $data->{mergedwith}= join(' ',grep($_ != $ref,@newmergelist));
- $data->{keywords}= join(' ', keys %tags);
- $data->{found_versions}= [sort keys %found];
- $data->{fixed_versions}= [sort keys %fixed];
- my @field_list = qw(forwarded package severity blocks blockedby owner done);
- @{$data}{@field_list} = @{$master_bug_data}{@field_list};
- &savebug;
- }
- &transcript("$action\n\n");
- }
- &endmerge;
- } elsif (m/^clone\s+#?(\d+)\s+((-\d+\s+)*-\d+)\s*$/i) {
- $ok++;
-
- $origref = $1;
- @newclonedids = split /\s+/, $2;
- $newbugsneeded = scalar(@newclonedids);
-
- $ref = $origref;
- $bug_affected{$ref} = 1;
- if (&setbug) {
- if (length($data->{mergedwith})) {
- &transcript("$gBug is marked as being merged with others. Use an existing clone.\n\n");
- $errors++;
- &nochangebug;
- } else {
- &filelock("nextnumber.lock");
- open(N,"nextnumber") || &quit("nextnumber: read: $!");
- $v=<N>; $v =~ s/\n$// || &quit("nextnumber bad format");
- $firstref= $v+0; $v += $newbugsneeded;
- open(NN,">nextnumber"); print NN "$v\n"; close(NN);
- &unfilelock;
-
- $lastref = $firstref + $newbugsneeded - 1;
-
- if ($newbugsneeded == 1) {
- $action= "$gBug $origref cloned as bug $firstref.";
- } else {
- $action= "$gBug $origref cloned as bugs $firstref-$lastref.";
- }
-
- my $blocks = $data->{blocks};
- my $blockedby = $data->{blockedby};
-
- &getnextbug;
- my $ohash = get_hashname($origref);
- my $clone = $firstref;
- @bug_affected{@newclonedids} = 1 x @newclonedids;
- for $newclonedid (@newclonedids) {
- $clonebugs{$newclonedid} = $clone;
-
- my $hash = get_hashname($clone);
- copy("db-h/$ohash/$origref.log", "db-h/$hash/$clone.log");
- copy("db-h/$ohash/$origref.status", "db-h/$hash/$clone.status");
- copy("db-h/$ohash/$origref.summary", "db-h/$hash/$clone.summary");
- copy("db-h/$ohash/$origref.report", "db-h/$hash/$clone.report");
- &bughook('new', $clone, $data);
-
- # Update blocking info of bugs blocked by or blocking the
- # cloned bug.
- foreach $ref (split ' ', $blocks) {
- &getbug;
- $data->{blockedby} = manipset($data->{blockedby}, $clone, 1);
- &savebug;
- }
- foreach $ref (split ' ', $blockedby) {
- &getbug;
- $data->{blocks} = manipset($data->{blocks}, $clone, 1);
- &savebug;
- }
-
- $clone++;
- }
- }
- }
- } elsif (m/^package\:?\s+(\S.*\S)?\s*$/i) {
- $ok++;
- my @pkgs = split /\s+/, $1;
- if (scalar(@pkgs) > 0) {
- %limit_pkgs = map { ($_, 1) } @pkgs;
- &transcript("Ignoring bugs not assigned to: " .
- join(" ", keys(%limit_pkgs)) . "\n\n");
- } else {
- %limit_pkgs = ();
- &transcript("Not ignoring any bugs.\n\n");
- }
- } elsif (m/^owner\s+\#?(-?\d+)\s+!$/i ? ($newowner = $replyto, 1) :
- m/^owner\s+\#?(-?\d+)\s+(\S.*\S)$/i ? ($newowner = $2, 1) : 0) {
- $ok++;
- $ref = $1;
- $bug_affected{$ref} = 1;
- if (&setbug) {
- if (length $data->{owner}) {
- $action = "Owner changed from $data->{owner} to $newowner.";
- } else {
- $action = "Owner recorded as $newowner.";
- }
- if (length $data->{done}) {
- $extramessage = "(By the way, this $gBug is currently " .
- "marked as done.)\n";
- }
- do {
- &addmaintainers($data);
- $data->{owner} = $newowner;
- } while (&getnextbug);
- }
- } elsif (m/^noowner\s+\#?(-?\d+)$/i) {
- $ok++;
- $ref = $1;
- $bug_affected{$ref} = 1;
- if (&setbug) {
- if (length $data->{owner}) {
- $action = "Removed annotation that $gBug was owned by " .
- "$data->{owner}.";
- do {
- &addmaintainers($data);
- $data->{owner} = '';
- } while (&getnextbug);
- } else {
- &transcript("$gBug is not marked as having an owner.\n\n");
- &nochangebug;
- }
- }
- } elsif (m/^unarchive\s+#?(\d+)$/i) {
- $ok++;
- $ref = $1;
- $bug_affected{$ref} = 1;
- my $transcript;
- eval {
- bug_unarchive(bug => $ref,
- transcript => \$transcript,
- affected_bugs => \%bug_affected,
- requester => $header{from},
- request_addr => $controlrequestaddr,
- message => \@log,
- );
- };
- if ($@) {
- $errors++;
- }
- transcript($transcript."\n");
- } elsif (m/^archive\s+#?(\d+)$/i) {
- $ok++;
- $ref = $1;
- $bug_affected{$ref} = 1;
- if (&setbug) {
- if (exists $data->{unarchived}) {
- my $transcript;
- nochangebug();
- eval {
- bug_archive(bug => $ref,
- transcript => \$transcript,
- ignore_time => 1,
- affected_bugs => \%bug_affected,
- requester => $header{from},
- request_addr => $controlrequestaddr,
- message => \@log,
- );
- };
- if ($@) {
- $errors++;
- }
- transcript($transcript."\n");
- }
- else {
- transcript("$gBug $ref has not been archived previously\n\n");
- nochangebug();
- $errors++;
- }
- }
- } else {
- &transcript("Unknown command or malformed arguments to command.\n\n");
- $errors++;
- if (++$unknowns >= 5) {
- &transcript("Too many unknown commands, stopping here.\n\n");
- last;
- }
- }
-}
-if ($procline>$#bodylines) {
- &transcript(">\nEnd of message, stopping processing here.\n\n");
-}
-if (!$ok && !quickabort) {
- $errors++;
- &transcript("No commands successfully parsed; sending the help text(s).\n");
- &sendhelp;
- &transcript("\n");
-}
-
-&transcript("MC\n") if $dl>1;
-@maintccs= ();
-for $maint (keys %maintccreasons) {
-&transcript("MM|$maint|\n") if $dl>1;
- next if $maint eq $replyto;
- $reasonstring= '';
- $reasonsref= $maintccreasons{$maint};
-&transcript("MY|$maint|\n") if $dl>2;
- for $p (sort keys %$reasonsref) {
-&transcript("MP|$p|\n") if $dl>2;
- $reasonstring.= ', ' if length($reasonstring);
- $reasonstring.= $p.' ' if length($p);
- $reasonstring.= join(' ',map("#$_",sort keys %{$$reasonsref{$p}}));
- }
- if (length($reasonstring) > 40) {
- (substr $reasonstring, 37) = "...";
- }
- $reasonstring = "" if (!defined($reasonstring));
- push(@maintccs,"$maint ($reasonstring)");
- push(@maintccaddrs,"$maint");
-}
-
-$maintccs = "";
-if (@maintccs) {
- &transcript("MC|@maintccs|\n") if $dl>2;
- $maintccs .= "Cc: " . join(",\n ",@maintccs) . "\n";
-}
-
-my %packagepr;
-for my $maint (keys %maintccreasons) {
- for my $package (keys %{$maintccreasons{$maint}}) {
- next unless length $package;
- $packagepr{$package} = 1;
- }
-}
-my $packagepr = '';
-$packagepr = "X-${gProject}-PR-Package: " . join(keys %packagepr) . "\n" if keys %packagepr;
-
-# Add Bcc's to subscribed bugs
-push @bcc, map {"bugs=$_\@$gListDomain"} keys %bug_affected;
-
-if (!defined $header{'subject'} || $header{'subject'} eq "") {
- $header{'subject'} = "your mail";
-}
-
-# Error text here advertises how many errors there were
-my $error_text = $errors > 0 ? " (with $errors errors)":'';
-
-$reply= <<END;
-From: $gMaintainerEmail ($gProject $gBug Tracking System)
-To: $replyto
-${maintccs}Subject: Processed${error_text}: $header{'subject'}
-In-Reply-To: $header{'message-id'}
-References: $header{'message-id'}
-Message-ID: <handler.s.$nn.transcript\@$gEmailDomain>
-Precedence: bulk
-${packagepr}X-$gProject-PR-Message: transcript
-
-${transcript}Please contact me if you need assistance.
-
-$gMaintainer
-(administrator, $gProject $gBugs database)
-$extras
-END
-
-$repliedshow= join(', ',$replyto,@maintccaddrs);
-# -1 is the service.in log
-&filelock("lock/-1");
-open(AP,">>db-h/-1.log") || &quit("open db-h/-1.log: $!");
-print(AP
- "\2\n$repliedshow\n\5\n$reply\n\3\n".
- "\6\n".
- "<strong>Request received</strong> from <code>".
- html_escape($header{'from'})."</code>\n".
- "to <code>".html_escape($controlrequestaddr)."</code>\n".
- "\3\n".
- "\7\n",escape_log(@log),"\n\3\n") || &quit("writing db-h/-1.log: $!");
-close(AP) || &quit("open db-h/-1.log: $!");
-&unfilelock;
-utime(time,time,"db-h");
-
-&sendmailmessage($reply,exists $header{'x-debbugs-no-ack'}?():$replyto,@maintccaddrs,@bcc);
-
-unlink("incoming/P$nn") || &quit("unlinking incoming/P$nn: $!");
-
-sub sendmailmessage {
- local ($message,@recips) = @_;
- $message = "X-Loop: $gMaintainerEmail\n" . $message;
- send_mail_message(message => $message,
- recipients => \@recips,
- );
- $midix++;
-}
-
-sub fill_template{
- my ($template,$extra_var) = @_;
- $extra_var ||={};
- my $variables = {config => \%config,
- defined($ref)?(ref => $ref):(),
- defined($data)?(data => $data):(),
- %{$extra_var},
- };
- my $hole_var = {'&bugurl' =>
- sub{"$_[0]: ".
- 'http://'.$config{cgi_domain}.'/'.
- Debbugs::CGI::bug_url($_[0]);
- }
- };
- return fill_in_template(template => $template,
- variables => $variables,
- hole_var => $hole_var,
- );
-}
-
-=head2 message_body_template
-
- message_body_template('mail/ack',{ref=>'foo'});
-
-Creates a message body using a template
-
-=cut
-
-sub message_body_template{
- my ($template,$extra_var) = @_;
- $extra_var ||={};
- my $body = fill_template($template,$extra_var);
- return fill_template('mail/message_body',
- {%{$extra_var},
- body => $body,
- },
- );
-}
-
-sub sendhelp {
- &sendtxthelpraw("bug-log-mailserver.txt","instructions for request\@$gEmailDomain");
- &sendtxthelpraw("bug-maint-mailcontrol.txt","instructions for control\@$gEmailDomain")
- if $control;
-}
-
-#sub unimplemented {
-# &transcript("Sorry, command $_[0] not yet implemented.\n\n");
-#}
-
-sub checkmatch {
- local ($string,$mvarname,$svarvalue,@newmergelist) = @_;
- local ($mvarvalue);
- if (@newmergelist) {
- eval "\$mvarvalue= \$$mvarname";
- &transcript("D| checkmatch \`$string' /$mvarname/$mvarvalue/$svarvalue/\n")
- if $dl;
- $mismatch .=
- "Values for \`$string' don't match:\n".
- " #$newmergelist[0] has \`$mvarvalue';\n".
- " #$ref has \`$svarvalue'\n"
- if $mvarvalue ne $svarvalue;
- } else {
- &transcript("D| setupmatch \`$string' /$mvarname/$svarvalue/\n")
- if $dl;
- eval "\$$mvarname= \$svarvalue";
- }
-}
-
-sub checkpkglimit {
- if (keys %limit_pkgs and not defined $limit_pkgs{$data->{package}}) {
- &transcript("$gBug number $ref belongs to package $data->{package}, skipping.\n\n");
- $errors++;
- return 0;
- }
- return 1;
-}
-
-sub manipset {
- my $list = shift;
- my $elt = shift;
- my $add = shift;
-
- my %h = map { $_ => 1 } split ' ', $list;
- if ($add) {
- $h{$elt}=1;
- }
- else {
- delete $h{$elt};
- }
- return join ' ', sort keys %h;
-}
-
-# High-level bug manipulation calls
-# Do announcements themselves
-#
-# Possible calling sequences:
-# setbug (returns 0)
-#
-# setbug (returns 1)
-# &transcript(something)
-# nochangebug
-#
-# setbug (returns 1)
-# $action= (something)
-# do {
-# (modify s_* variables)
-# } while (getnextbug);
-
-sub nochangebug {
- &dlen("nochangebug");
- $state eq 'single' || $state eq 'multiple' || die "$state ?";
- &cancelbug;
- &endmerge if $manybugs;
- $state= 'idle';
- &dlex("nochangebug");
-}
-
-sub setbug {
- &dlen("setbug $ref");
- if ($ref =~ m/^-\d+/) {
- if (!defined $clonebugs{$ref}) {
- ¬foundbug;
- &dlex("setbug => noclone");
- return 0;
- }
- $ref = $clonebugs{$ref};
- }
- $state eq 'idle' || die "$state ?";
- if (!&getbug) {
- ¬foundbug;
- &dlex("setbug => 0s");
- return 0;
- }
-
- if (!&checkpkglimit) {
- &cancelbug;
- return 0;
- }
-
- @thisbugmergelist= split(/ /,$data->{mergedwith});
- if (!@thisbugmergelist) {
- &foundbug;
- $manybugs= 0;
- $state= 'single';
- $sref=$ref;
- &dlex("setbug => 1s");
- return 1;
- }
- &cancelbug;
- &getmerge;
- $manybugs= 1;
- if (!&getbug) {
- ¬foundbug;
- &endmerge;
- &dlex("setbug => 0mc");
- return 0;
- }
- &foundbug;
- $state= 'multiple'; $sref=$ref;
- &dlex("setbug => 1m");
- return 1;
-}
-
-sub getnextbug {
- &dlen("getnextbug");
- $state eq 'single' || $state eq 'multiple' || die "$state ?";
- &savebug;
- if (!$manybugs || !@thisbugmergelist) {
- length($action) || die;
- &transcript("$action\n$extramessage\n");
- &endmerge if $manybugs;
- $state= 'idle';
- &dlex("getnextbug => 0");
- return 0;
- }
- $ref= shift(@thisbugmergelist);
- &getbug || die "bug $ref disappeared";
- &foundbug;
- &dlex("getnextbug => 1");
- return 1;
-}
-
-# Low-level bug-manipulation calls
-# Do no announcements
-#
-# getbug (returns 0)
-#
-# getbug (returns 1)
-# cancelbug
-#
-# getmerge
-# $action= (something)
-# getbug (returns 1)
-# savebug/cancelbug
-# getbug (returns 1)
-# savebug/cancelbug
-# [getbug (returns 0)]
-# &transcript("$action\n\n")
-# endmerge
-
-sub notfoundbug { &transcript("$gBug number $ref not found. (Is it archived?)\n\n"); }
-sub foundbug { &transcript("$gBug#$ref: $data->{subject}\n"); }
-
-sub getmerge {
- &dlen("getmerge");
- $mergelowstate eq 'idle' || die "$mergelowstate ?";
- &filelock('lock/merge');
- $mergelowstate='locked';
- &dlex("getmerge");
-}
-
-sub endmerge {
- &dlen("endmerge");
- $mergelowstate eq 'locked' || die "$mergelowstate ?";
- &unfilelock;
- $mergelowstate='idle';
- &dlex("endmerge");
-}
-
-sub getbug {
- &dlen("getbug $ref");
- $lowstate eq 'idle' || die "$state ?";
- # Only use unmerged bugs here
- if (($data = &lockreadbug($ref,'db-h'))) {
- $sref= $ref;
- $lowstate= "open";
- &dlex("getbug => 1");
- $extramessage='';
- return 1;
- }
- $lowstate= 'idle';
- &dlex("getbug => 0");
- return 0;
-}
-
-sub cancelbug {
- &dlen("cancelbug");
- $lowstate eq 'open' || die "$state ?";
- &unfilelock;
- $lowstate= 'idle';
- &dlex("cancelbug");
-}
-
-sub savebug {
- &dlen("savebug $ref");
- $lowstate eq 'open' || die "$lowstate ?";
- length($action) || die;
- $ref == $sref || die "read $sref but saving $ref ?";
- append_action_to_log(bug => $ref,
- action => $action,
- requester => $header{from},
- request_addr => $controlrequestaddr,
- message => \@log,
- get_lock => 0,
- );
- unlockwritebug($ref, $data);
- $lowstate= "idle";
- &dlex("savebug");
-}
-
-sub dlen {
- return if !$dl;
- &transcript("C> @_ ($state $lowstate $mergelowstate)\n");
-}
-
-sub dlex {
- return if !$dl;
- &transcript("R> @_ ($state $lowstate $mergelowstate)\n");
-}
-
-sub transcript {
- print $_[0] if $debug;
- $transcript.= $_[0];
-}
-
-sub urlsanit {
- my $url = shift;
- $url =~ s/%/%25/g;
- $url =~ s/\+/%2b/g;
- my %saniarray = ('<','lt', '>','gt', '&','amp', '"','quot');
- $url =~ s/([<>&"])/\&$saniarray{$1};/g;
- return $url;
-}
-
-sub sendlynxdoc {
- &sendlynxdocraw;
- &transcript("\n");
- $ok++;
-}
-
-sub sendtxthelp {
- &sendtxthelpraw;
- &transcript("\n");
- $ok++;
-}
-
-sub sendtxthelpraw {
- local ($relpath,$description) = @_;
- $doc='';
- open(D,"$gDocDir/$relpath") || &quit("open doc file $relpath: $!");
- while(<D>) { $doc.=$_; }
- close(D);
- &transcript("Sending $description in separate message.\n");
- &sendmailmessage(<<END.$doc,$replyto);
-From: $gMaintainerEmail ($gProject $gBug Tracking System)
-To: $replyto
-Subject: $gProject $gBug help: $description
-References: $header{'message-id'}
-In-Reply-To: $header{'message-id'}
-Message-ID: <handler.s.$nn.help.$midix\@$gEmailDomain>
-Precedence: bulk
-X-$gProject-PR-Message: doc-text $relpath
-
-END
- $ok++;
-}
-
-sub sendlynxdocraw {
- local ($relpath,$description) = @_;
- $doc='';
- open(L,"lynx -nolist -dump http://$gCGIDomain/\Q$relpath\E 2>&1 |") || &quit("fork for lynx: $!");
- while(<L>) { $doc.=$_; }
- $!=0; close(L);
- if ($? == 255 && $doc =~ m/^\n*lynx: Can\'t access start file/) {
- &transcript("Information ($description) is not available -\n".
- "perhaps the $gBug does not exist or is not on the WWW yet.\n");
- $ok++;
- } elsif ($?) {
- &transcript("Error getting $description (code $? $!):\n$doc\n");
- } else {
- &transcript("Sending $description.\n");
- &sendmailmessage(<<END.$doc,$replyto);
-From: $gMaintainerEmail ($gProject $gBug Tracking System)
-To: $replyto
-Subject: $gProject $gBugs information: $description
-References: $header{'message-id'}
-In-Reply-To: $header{'message-id'}
-Message-ID: <handler.s.$nn.info.$midix\@$gEmailDomain>
-Precedence: bulk
-X-$gProject-PR-Message: doc-html $relpath
-
-END
- $ok++;
- }
-}
-
-sub addccaddress {
- my ($cca) = @_;
- $maintccreasons{$cca}{''}{$ref}= 1;
-}
-
-sub addmaintainers {
- # Data structure is:
- # maintainer email address &c -> assoc of packages -> assoc of bug#'s
- my $data = shift;
- my ($p, $addmaint);
- &ensuremaintainersloaded;
- $anymaintfound=0; $anymaintnotfound=0;
- for $p (split(m/[ \t?,():]+/, $data->{package})) {
- $p =~ y/A-Z/a-z/;
- $p =~ /([a-z0-9.+-]+)/;
- $p = $1;
- next unless defined $p;
- if (defined $gSubscriptionDomain) {
- if (defined($pkgsrc{$p})) {
- addbcc("$pkgsrc{$p}\@$gSubscriptionDomain");
- } else {
- addbcc("$p\@$gSubscriptionDomain");
- }
- }
- if (defined $data->{severity} and defined $gStrongList and
- isstrongseverity($data->{severity})) {
- addbcc("$gStrongList\@$gListDomain");
- }
- if (defined($maintainerof{$p})) {
- $addmaint= $maintainerof{$p};
- &transcript("MR|$addmaint|$p|$ref|\n") if $dl>2;
- $maintccreasons{$addmaint}{$p}{$ref}= 1;
- print "maintainer add >$p|$addmaint<\n" if $debug;
- } else {
- print "maintainer none >$p<\n" if $debug;
- &transcript("Warning: Unknown package '$p'\n");
- &transcript("MR|unknown-package|$p|$ref|\n") if $dl>2;
- $maintccreasons{$gUnknownMaintainerEmail}{$p}{$ref}= 1;
- }
- }
-
- if (length $data->{owner}) {
- $addmaint = $data->{owner};
- &transcript("MO|$addmaint|$data->{package}|$ref|\n") if $dl>2;
- $maintccreasons{$addmaint}{$data->{package}}{$ref} = 1;
- print "owner add >$data->{package}|$addmaint<\n" if $debug;
- }
-}
-
-sub ensuremaintainersloaded {
- my ($a,$b);
- return if $maintainersloaded++;
- open(MAINT,"$gMaintainerFile") || die &quit("maintainers open: $!");
- while (<MAINT>) {
- m/^\n$/ && next;
- m/^\s*$/ && next;
- m/^(\S+)\s+(\S.*\S)\s*\n$/ || &quit("maintainers bogus \`$_'");
- $a= $1; $b= $2; $a =~ y/A-Z/a-z/;
- $maintainerof{$a}= $2;
- }
- close(MAINT);
- open(MAINT,"$gMaintainerFileOverride") || die &quit("maintainers.override open: $!");
- while (<MAINT>) {
- m/^\n$/ && next;
- m/^\s*$/ && next;
- m/^(\S+)\s+(\S.*\S)\s*\n$/ || &quit("maintainers.override bogus \`$_'");
- $a= $1; $b= $2; $a =~ y/A-Z/a-z/;
- $maintainerof{$a}= $2;
- }
-
- open(SOURCES, "$gPackageSource") || &quit("pkgsrc open: $!");
- while (<SOURCES>) {
- next unless m/^(\S+)\s+\S+\s+(\S.*\S)\s*$/;
- my ($a, $b) = ($1, $2);
- $pkgsrc{lc($a)} = $b;
- }
- close(SOURCES);
-}
-
-sub sendinfo {
- local ($wherefrom,$path,$description) = @_;
- if ($wherefrom eq "ftp.d.o") {
- $doc = `lynx -nolist -dump http://ftp.debian.org/debian/indices/$path.gz 2>&1 | gunzip -cf` or &quit("fork for lynx/gunzip: $!");
- $! = 0;
- if ($? == 255 && $doc =~ m/^\n*lynx: Can\'t access start file/) {
- &transcript("$description is not available.\n");
- $ok++; return;
- } elsif ($?) {
- &transcript("Error getting $description (code $? $!):\n$doc\n");
- return;
- }
- } elsif ($wherefrom eq "local") {
- open P, "$path";
- $doc = do { local $/; <P> };
- close P;
- } else {
- &transcript("internal errror: info files location unknown.\n");
- $ok++; return;
- }
- &transcript("Sending $description.\n");
- &sendmailmessage(<<END.$doc,$replyto);
-From: $gMaintainerEmail ($gProject $gBug Tracking System)
-To: $replyto
-Subject: $gProject $gBugs information: $description
-References: $header{'message-id'}
-In-Reply-To: $header{'message-id'}
-Message-ID: <handler.s.$nn.info.$midix\@$gEmailDomain>
-Precedence: bulk
-X-$gProject-PR-Message: getinfo
-
-$description follows:
-
-END
- $ok++;
- &transcript("\n");
-}
--- /dev/null
+#! /usr/bin/perl
+# $Id: spamscan.in,v 1.8 2005/02/01 07:54:01 blarson Exp $
+#
+# Usage: spamscan
+#
+# Performs SpamAssassin checks on a message before allowing it through to
+# the main incoming queue.
+#
+# Uses up: incoming/S<code><bugnum>.nn
+# Temps: incoming/R.nn
+# Creates: incoming/I.nn
+# Stop: spamscan-stop
+
+use warnings;
+use strict;
+
+use threads;
+use threads::shared;
+
+use Debbugs::Config qw(:config);
+
+use Debbugs::Common qw(:lock);
+
+use Mail::CrossAssassin;
+use Socket;
+use IO::Handle;
+use IPC::Open2;
+
+
+exit unless $config{spam_scan};
+
+chdir $config{spool_dir} or die "chdir spool: $!\n";
+
+umask 002;
+
+eval {
+ filelock('incoming-spamscan');
+};
+exit if $@;
+
+my %spamseen : shared = ();
+my @ids : shared = ();
+my %fudged : shared = ();
+my $spamscan_stop : shared = 0;
+my $cross_key : shared;
+my @cross_return : shared;
+my $cross_tid : shared;
+my $print_lock : shared;
+my $assassinated_lock : shared;
+my $crossassassinated_lock : shared;
+my $threadsrunning : shared = 0;
+
+# flush output immediately
+$| = 1;
+
+sub lprint ($) {
+ lock $print_lock;
+ print $_[0];
+}
+
+my $user_prefs = "$ENV{HOME}/.spamassassin/user_prefs";
+my $user_prefs_time;
+if (-e $user_prefs) {
+ $user_prefs_time = (stat $user_prefs)[9];
+} else {
+ die "$user_prefs not found";
+}
+
+# This thread handles the updating and querying of the crossassassin db
+sub cross {
+ ca_init('\b\d{3,8}(?:-(?:close|done|forwarded|maintonly|submitter|quiet|subscribe))?\@'.$config{email_domain}, $config{spam_crossassassin_db});
+ my $mytid = threads->self->tid();
+crosscheck:
+ while ($spamscan_stop <= 1) {
+ my ($ck, $ct);
+ {
+ lock $cross_key unless($cross_key);
+ until ($cross_key) {
+ last crosscheck if $spamscan_stop > 1;
+ lprint "{$mytid} cross waiting\n";
+ cond_timedwait $cross_key, (time() + 30);
+ }
+ last crosscheck if ($spamscan_stop > 1);
+ $ck = $cross_key;
+ $ct = $cross_tid;
+ undef $cross_key;
+ }
+ unless ($ck) {
+ lprint "{$mytid} Cross nothing\n";
+ sleep 1;
+ next crosscheck;
+ }
+ lprint "{$mytid} Cross{$ct}: $ck\n";
+ {
+ lock @cross_return;
+ $cross_return[$ct] = ca_set($ck);
+ cond_signal @cross_return;
+ }
+ }
+}
+
+# multiple threads handle spamassassin
+sub sa {
+ {
+ lock $threadsrunning;
+ $threadsrunning++;
+ }
+ my $mytid = threads->self->tid();
+ sleep $mytid + 3;
+ return if $spamscan_stop;
+ my ($sain, $saout);
+
+ my $pid = open2($saout, $sain, "/usr/lib/debbugs/spamscan-sa");
+ lprint "{$mytid} forked $pid\n";
+ my $messages_handled=0;
+pp: until ($spamscan_stop) {
+ my ($id, $nf);
+ lprint "{$mytid} $messages_handled messages handled\n";
+ $messages_handled++;
+getid: for (;;) {
+ {
+ lock @ids;
+ $nf = @ids;
+ $id = shift @ids;
+ last getid if $nf;
+ cond_timedwait @ids, (time() + 30);
+ last pp if $spamscan_stop;
+ $nf = @ids;
+ $id = shift @ids;
+ last getid if $nf;
+ }
+ lprint "{$mytid} Waiting for spam to process\n";
+ sleep 1;
+ }
+ print $sain "$id\n$nf\n";
+ lprint "{$mytid} $id is $nf\n";
+ my $keys = <$saout>;
+ unless (defined $keys) {
+ lprint "{$mytid} Could not get keys: $!\n";
+ last pp;
+ }
+ chomp $keys;
+ my $messageid = <$saout>;
+ unless (defined($messageid)) {
+ lprint "{$mytid} Could not read messageid: $!\n";
+ last pp;
+ }
+ chomp $messageid;
+ lprint "{$mytid} $id $keys\n";
+ my $ca_score;
+crosskey: for (;;) {
+ {
+ lock $cross_key;
+ unless ($cross_key) {
+ $cross_tid = $mytid;
+ $cross_key = $keys;
+ cond_signal $cross_key;
+ last crosskey;
+ }
+ }
+ lprint "{$mytid} zzz...\n";
+ select undef, undef, undef, 0.1;
+ }
+crossret: for (;;) {
+ {
+ lock @cross_return;
+ if ($cross_return[$mytid]) {
+ $ca_score = $cross_return[$mytid];
+ undef $cross_return[$mytid];
+ last crossret;
+ }
+ }
+ lprint "{$mytid} z z z...\n";
+ select undef, undef, undef, 0.1;
+ }
+ lprint "{$mytid} $id: ca_score: $ca_score\n";
+ my $seen = $spamseen{$messageid};
+ $seen = '' unless $seen;
+ unless(print $sain "$ca_score\n$seen\n") {
+ lprint "{$mytid} Could not send ca_score: $!\n";
+ last pp;
+ }
+ my $todo = <$saout>;
+ unless (defined($todo)) {
+ lprint "{$mytid} Could not read todo: $!\n";
+ last pp;
+ }
+ chomp $todo;
+ my $nseen;
+ if ($todo == 1) {
+ lock $assassinated_lock;
+ print $sain "$todo\n";
+ $nseen = <$saout>;
+ } elsif ($todo == 2) {
+ lock $crossassassinated_lock;
+ print $sain "$todo\n";
+ $nseen = <$saout>;
+ } else {
+ print $sain "$todo\n";
+ $nseen = <$saout>;
+ }
+ unless(defined($nseen)) {
+ lprint "{$mytid} Could not read seen: $!\n";
+ start_sa() if (scalar(@ids) > ($threadsrunning * $config{spam_spams_per_thread})
+ && $threadsrunning < $config{spam_max_threads});
+ last pp;
+ }
+ chomp $nseen;
+ $spamseen{$messageid} = $nseen if ($nseen);
+ my $out = <$saout>;
+ unless(defined($out)) {
+ lprint "{$mytid} Could not read out: $!\n";
+ last pp;
+ }
+ chomp $out;
+ $out =~ tr/\r/\n/;
+ lprint $out;
+ }
+ {
+ lock $threadsrunning;
+ $threadsrunning--;
+ }
+ close $sain;
+ close $saout;
+ waitpid($pid,0);
+}
+
+my @sa_threads;
+sub start_sa {
+ my $s = threads->create(\&sa)
+ or die "Could not start sa threads: $!";
+ $s->detach;
+ push @sa_threads, $s;
+}
+
+my $cross_thread = threads->create(\&cross)
+ or die "Could not start cross thread: $!";
+$cross_thread->detach;
+start_sa;
+# start_sa;
+
+my $stopafter = time() + $config{spam_keep_running};
+
+for (;;) {
+ alarm 180;
+ if (-f 'spamscan-stop') {
+ lprint "spamscan-stop file created\n";
+ last;
+ }
+ if ($user_prefs_time != (stat $user_prefs)[9]) {
+ # stop and wait to be re-invoked from cron
+ lprint "File $user_prefs changed\n";
+ last;
+ }
+
+ unless (@ids) {
+ if (time() > $stopafter) {
+ lprint "KeepRunning timer expired\n";
+ last;
+ }
+ my @i;
+ opendir DIR, 'incoming' or die "opendir incoming: $!";
+ while (defined($_ = readdir DIR)) {
+ push @i, $1 if /^S(.*)/;
+ }
+ unless (@i) {
+ lprint "No more spam to process\n";
+ last;
+ }
+ @i = sort {(split(/\./,$a))[1] <=> (split(/\./,$b))[1]} @i;
+ my $m = @i;
+ lprint "Messages to process: $m\n";
+ lock @ids;
+ push @ids, @i;
+ cond_broadcast @ids;
+ }
+ start_sa if (scalar(@ids) > (($threadsrunning - 1) * $config{spam_spams_per_thread})
+ && $threadsrunning < $config{spam_max_threads});
+ sleep 30;
+}
+
+alarm 180;
+
+# wait for the spamassasin threads
+$spamscan_stop = 1;
+{
+ lock @ids;
+ cond_broadcast @ids;
+}
+
+while (my $t = shift @sa_threads) {
+ my $tid = $t->tid;
+ lprint "{} waiting for thread $tid\n";
+ my $max_wait = 60;
+ while ($t->is_running and --$max_wait > 0) {
+ sleep 1;
+ }
+# $t->join;
+}
+
+# wait for the crossassasin thread
+$spamscan_stop = 2;
+{
+ lprint "{} waiting for cross thread\n";
+ lock $cross_key;
+ $cross_key = 1;
+ cond_signal $cross_key;
+}
+my $max_wait = 60;
+while ($cross_thread->is_running and --$max_wait > 0) {
+ sleep 1;
+}
+#$cross_thread->join;
+
+END{
+ foreach my $thread (threads->list()){
+ $thread->join;
+ }
+}
+
+&unfilelock;
+
+
+
+#exit 0;
+++ /dev/null
-#! /usr/bin/perl
-# $Id: spamscan.in,v 1.8 2005/02/01 07:54:01 blarson Exp $
-#
-# Usage: spamscan
-#
-# Performs SpamAssassin checks on a message before allowing it through to
-# the main incoming queue.
-#
-# Uses up: incoming/S<code><bugnum>.nn
-# Temps: incoming/R.nn
-# Creates: incoming/I.nn
-# Stop: spamscan-stop
-
-use warnings;
-use strict;
-
-use threads;
-use threads::shared;
-
-use Debbugs::Config qw(:config);
-
-use Debbugs::Common qw(:lock);
-
-use Mail::CrossAssassin;
-use Socket;
-use IO::Handle;
-use IPC::Open2;
-
-
-exit unless $config{spam_scan};
-
-chdir $config{spool_dir} or die "chdir spool: $!\n";
-
-umask 002;
-
-eval {
- filelock('incoming-spamscan');
-};
-exit if $@;
-
-my %spamseen : shared = ();
-my @ids : shared = ();
-my %fudged : shared = ();
-my $spamscan_stop : shared = 0;
-my $cross_key : shared;
-my @cross_return : shared;
-my $cross_tid : shared;
-my $print_lock : shared;
-my $assassinated_lock : shared;
-my $crossassassinated_lock : shared;
-my $threadsrunning : shared = 0;
-
-# flush output immediately
-$| = 1;
-
-sub lprint ($) {
- lock $print_lock;
- print $_[0];
-}
-
-my $user_prefs = "$ENV{HOME}/.spamassassin/user_prefs";
-my $user_prefs_time;
-if (-e $user_prefs) {
- $user_prefs_time = (stat $user_prefs)[9];
-} else {
- die "$user_prefs not found";
-}
-
-# This thread handles the updating and querying of the crossassassin db
-sub cross {
- ca_init('\b\d{3,8}(?:-(?:close|done|forwarded|maintonly|submitter|quiet|subscribe))?\@'.$config{email_domain}, $config{spam_crossassassin_db});
- my $mytid = threads->self->tid();
-crosscheck:
- while ($spamscan_stop <= 1) {
- my ($ck, $ct);
- {
- lock $cross_key unless($cross_key);
- until ($cross_key) {
- last crosscheck if $spamscan_stop > 1;
- lprint "{$mytid} cross waiting\n";
- cond_timedwait $cross_key, (time() + 30);
- }
- last crosscheck if ($spamscan_stop > 1);
- $ck = $cross_key;
- $ct = $cross_tid;
- undef $cross_key;
- }
- unless ($ck) {
- lprint "{$mytid} Cross nothing\n";
- sleep 1;
- next crosscheck;
- }
- lprint "{$mytid} Cross{$ct}: $ck\n";
- {
- lock @cross_return;
- $cross_return[$ct] = ca_set($ck);
- cond_signal @cross_return;
- }
- }
-}
-
-# multiple threads handle spamassassin
-sub sa {
- {
- lock $threadsrunning;
- $threadsrunning++;
- }
- my $mytid = threads->self->tid();
- sleep $mytid + 3;
- return if $spamscan_stop;
- my ($sain, $saout);
-
- my $pid = open2($saout, $sain, "/usr/lib/debbugs/spamscan-sa");
- lprint "{$mytid} forked $pid\n";
- my $messages_handled=0;
-pp: until ($spamscan_stop) {
- my ($id, $nf);
- lprint "{$mytid} $messages_handled messages handled\n";
- $messages_handled++;
-getid: for (;;) {
- {
- lock @ids;
- $nf = @ids;
- $id = shift @ids;
- last getid if $nf;
- cond_timedwait @ids, (time() + 30);
- last pp if $spamscan_stop;
- $nf = @ids;
- $id = shift @ids;
- last getid if $nf;
- }
- lprint "{$mytid} Waiting for spam to process\n";
- sleep 1;
- }
- print $sain "$id\n$nf\n";
- lprint "{$mytid} $id is $nf\n";
- my $keys = <$saout>;
- unless (defined $keys) {
- lprint "{$mytid} Could not get keys: $!\n";
- last pp;
- }
- chomp $keys;
- my $messageid = <$saout>;
- unless (defined($messageid)) {
- lprint "{$mytid} Could not read messageid: $!\n";
- last pp;
- }
- chomp $messageid;
- lprint "{$mytid} $id $keys\n";
- my $ca_score;
-crosskey: for (;;) {
- {
- lock $cross_key;
- unless ($cross_key) {
- $cross_tid = $mytid;
- $cross_key = $keys;
- cond_signal $cross_key;
- last crosskey;
- }
- }
- lprint "{$mytid} zzz...\n";
- select undef, undef, undef, 0.1;
- }
-crossret: for (;;) {
- {
- lock @cross_return;
- if ($cross_return[$mytid]) {
- $ca_score = $cross_return[$mytid];
- undef $cross_return[$mytid];
- last crossret;
- }
- }
- lprint "{$mytid} z z z...\n";
- select undef, undef, undef, 0.1;
- }
- lprint "{$mytid} $id: ca_score: $ca_score\n";
- my $seen = $spamseen{$messageid};
- $seen = '' unless $seen;
- unless(print $sain "$ca_score\n$seen\n") {
- lprint "{$mytid} Could not send ca_score: $!\n";
- last pp;
- }
- my $todo = <$saout>;
- unless (defined($todo)) {
- lprint "{$mytid} Could not read todo: $!\n";
- last pp;
- }
- chomp $todo;
- my $nseen;
- if ($todo == 1) {
- lock $assassinated_lock;
- print $sain "$todo\n";
- $nseen = <$saout>;
- } elsif ($todo == 2) {
- lock $crossassassinated_lock;
- print $sain "$todo\n";
- $nseen = <$saout>;
- } else {
- print $sain "$todo\n";
- $nseen = <$saout>;
- }
- unless(defined($nseen)) {
- lprint "{$mytid} Could not read seen: $!\n";
- start_sa() if (scalar(@ids) > ($threadsrunning * $config{spam_spams_per_thread})
- && $threadsrunning < $config{spam_max_threads});
- last pp;
- }
- chomp $nseen;
- $spamseen{$messageid} = $nseen if ($nseen);
- my $out = <$saout>;
- unless(defined($out)) {
- lprint "{$mytid} Could not read out: $!\n";
- last pp;
- }
- chomp $out;
- $out =~ tr/\r/\n/;
- lprint $out;
- }
- {
- lock $threadsrunning;
- $threadsrunning--;
- }
- close $sain;
- close $saout;
- waitpid($pid,0);
-}
-
-my @sa_threads;
-sub start_sa {
- my $s = threads->create(\&sa)
- or die "Could not start sa threads: $!";
- $s->detach;
- push @sa_threads, $s;
-}
-
-my $cross_thread = threads->create(\&cross)
- or die "Could not start cross thread: $!";
-$cross_thread->detach;
-start_sa;
-# start_sa;
-
-my $stopafter = time() + $config{spam_keep_running};
-
-for (;;) {
- alarm 180;
- if (-f 'spamscan-stop') {
- lprint "spamscan-stop file created\n";
- last;
- }
- if ($user_prefs_time != (stat $user_prefs)[9]) {
- # stop and wait to be re-invoked from cron
- lprint "File $user_prefs changed\n";
- last;
- }
-
- unless (@ids) {
- if (time() > $stopafter) {
- lprint "KeepRunning timer expired\n";
- last;
- }
- my @i;
- opendir DIR, 'incoming' or die "opendir incoming: $!";
- while (defined($_ = readdir DIR)) {
- push @i, $1 if /^S(.*)/;
- }
- unless (@i) {
- lprint "No more spam to process\n";
- last;
- }
- @i = sort {(split(/\./,$a))[1] <=> (split(/\./,$b))[1]} @i;
- my $m = @i;
- lprint "Messages to process: $m\n";
- lock @ids;
- push @ids, @i;
- cond_broadcast @ids;
- }
- start_sa if (scalar(@ids) > (($threadsrunning - 1) * $config{spam_spams_per_thread})
- && $threadsrunning < $config{spam_max_threads});
- sleep 30;
-}
-
-alarm 180;
-
-# wait for the spamassasin threads
-$spamscan_stop = 1;
-{
- lock @ids;
- cond_broadcast @ids;
-}
-
-while (my $t = shift @sa_threads) {
- my $tid = $t->tid;
- lprint "{} waiting for thread $tid\n";
- my $max_wait = 60;
- while ($t->is_running and --$max_wait > 0) {
- sleep 1;
- }
-# $t->join;
-}
-
-# wait for the crossassasin thread
-$spamscan_stop = 2;
-{
- lprint "{} waiting for cross thread\n";
- lock $cross_key;
- $cross_key = 1;
- cond_signal $cross_key;
-}
-my $max_wait = 60;
-while ($cross_thread->is_running and --$max_wait > 0) {
- sleep 1;
-}
-#$cross_thread->join;
-
-END{
- foreach my $thread (threads->list()){
- $thread->join;
- }
-}
-
-&unfilelock;
-
-
-
-#exit 0;
--- /dev/null
+#!/usr/bin/perl
+# $Id: summary.in,v 1.11 2004/04/17 17:31:04 cjwatson Exp $
+
+$config_path = '/etc/debbugs';
+$lib_path = '/usr/lib/debbugs';
+
+require("$config_path/config");
+require("$lib_path/errorlib");
+$ENV{'PATH'} = $lib_path.':'.$ENV{'PATH'};
+
+chdir("$gSpoolDir") || die "chdir spool: $!\n";
+
+#open(DEBUG,">&4");
+
+$mode= shift(@ARGV);
+
+open(M,"$gMaintainerFile") || die "open $gMaintainerFile: $!";
+while (<M>) {
+ m/^(\S+)\s+(\S.*\S)\s*$/ || warn "$_ ?";
+ ($a,$b)=($1,$2);
+ $a =~ y/A-Z/a-z/;
+ $maintainer{$a}= $b;
+}
+close(M);
+open(M,"$gMaintainerFileOverride") || die "open $gMaintainerFileOverride: $!";
+while (<M>) {
+ m/^(\S+)\s+(\S.*\S)\s*$/ || warn "$_ ?";
+ ($a,$b)=($1,$2);
+ $a =~ y/A-Z/a-z/;
+ $maintainer{$a}= $b;
+}
+close(M);
+
+
+defined($startdate= time) || die "failed to get time: $!";
+
+opendir(DIR,"db-h") || die "opendir db-h: $!\n";
+@dirs = grep(s,^,db-h/,, grep(m/^\d+$/,readdir(DIR)));
+closedir(DIR);
+foreach my $dir (@dirs) {
+ opendir(DIR,$dir);
+ push @list, grep(s/\.status$//,grep(m/^\d+\.status$/,readdir(DIR)));
+ closedir(DIR);
+}
+@list = sort { $a <=> $b } @list;
+
+$head= $mode eq 'bymaint'
+ ? ' Package Ref Subject'
+ : ' Ref Package Keywords/Subject Package maintainer';
+$amonths=-1;
+
+while (length($f=shift(@list))) {
+ if (!($data = lockreadbug($f))) { next; }
+ $_= $data->{package}; y/A-Z/a-z/; $_= $` if m/[^-+._a-z0-9]/;
+ $data->{maintainer}=
+ defined($maintainer{$_}) ? $maintainer{$_} :
+ length($_) ? "(unknown -- \`$_')" :
+ "(unknown)";
+ if ($mode eq 'undone' || $mode eq 'veryold') {
+ &unfilelock;
+ next if length($data->{done}) || length($data->{forwarded});
+ $cmonths= int(($startdate - $data->{date})/2592000); # 3600*24*30 (30 days)
+ next if $mode eq 'veryold' && $cmonths < 2;
+ if ($cmonths != $amonths) {
+ $msg= $cmonths == 0 ? "Submitted in the last month" :
+ $cmonths == 1 ? "Over one month old" :
+ $cmonths == 2 ? "Over two months old - attention is required" :
+ "OVER $cmonths MONTHS OLD - ATTENTION IS REQUIRED";
+ print "\n$msg:\n$head\n";
+ $amonths= $cmonths;
+ }
+ printf("%6d %-10.10s %-30.30s %-.31s\n", $f, $data->{package},
+ (length($data->{keywords}) ? $data->{keywords}.'/' : '').$data->{subject},
+ $data->{maintainer}) || die "output undone: $!";
+ } elsif ($mode eq 'bymaint') {
+ &unfilelock;
+ next if length($data->{done}) || length($data->{forwarded});
+ $string{$f}=
+ sprintf(" %-10.10s %6d %-.59s\n", $data->{package}, $f, $data->{subject});
+ $data->{maintainer}= "(unknown)" if $data->{maintainer} =~ m/^\(unknown \-\-/;
+ $maintainercnt{$data->{maintainer}}++;
+ $maintainerlist{$data->{maintainer}}.= " $f";
+ } else {
+ die "badmode $mode";
+ }
+}
+
+if ($mode eq 'bymaint') {
+ print("$head\n") || die "output head: $!";
+ for $m (sort { $maintainercnt{$a} <=> $maintainercnt{$b} } keys %maintainercnt) {
+ printf("\n%s (%d $gBugs):\n",$m,$maintainercnt{$m})
+ || die "output mainthead: $!";
+ for $i (sort { $string{$a} cmp $string{$b} } split(/ /,$maintainerlist{$m})) {
+ printf($string{$i}) || die "output 1bymaint: $!";
+ }
+ }
+}
+
+close(STDOUT) || die "close stdout: $!";
+++ /dev/null
-#!/usr/bin/perl
-# $Id: summary.in,v 1.11 2004/04/17 17:31:04 cjwatson Exp $
-
-$config_path = '/etc/debbugs';
-$lib_path = '/usr/lib/debbugs';
-
-require("$config_path/config");
-require("$lib_path/errorlib");
-$ENV{'PATH'} = $lib_path.':'.$ENV{'PATH'};
-
-chdir("$gSpoolDir") || die "chdir spool: $!\n";
-
-#open(DEBUG,">&4");
-
-$mode= shift(@ARGV);
-
-open(M,"$gMaintainerFile") || &quit("open $gMaintainerFile: $!");
-while (<M>) {
- m/^(\S+)\s+(\S.*\S)\s*$/ || warn "$_ ?";
- ($a,$b)=($1,$2);
- $a =~ y/A-Z/a-z/;
- $maintainer{$a}= $b;
-}
-close(M);
-open(M,"$gMaintainerFileOverride") || &quit("open $gMaintainerFileOverride: $!");
-while (<M>) {
- m/^(\S+)\s+(\S.*\S)\s*$/ || warn "$_ ?";
- ($a,$b)=($1,$2);
- $a =~ y/A-Z/a-z/;
- $maintainer{$a}= $b;
-}
-close(M);
-
-
-defined($startdate= time) || &quit("failed to get time: $!");
-
-opendir(DIR,"db-h") || &quit("opendir db-h: $!\n");
-@dirs = grep(s,^,db-h/,, grep(m/^\d+$/,readdir(DIR)));
-closedir(DIR);
-foreach my $dir (@dirs) {
- opendir(DIR,$dir);
- push @list, grep(s/\.status$//,grep(m/^\d+\.status$/,readdir(DIR)));
- closedir(DIR);
-}
-@list = sort { $a <=> $b } @list;
-
-$head= $mode eq 'bymaint'
- ? ' Package Ref Subject'
- : ' Ref Package Keywords/Subject Package maintainer';
-$amonths=-1;
-
-while (length($f=shift(@list))) {
- if (!($data = lockreadbug($f))) { next; }
- $_= $data->{package}; y/A-Z/a-z/; $_= $` if m/[^-+._a-z0-9]/;
- $data->{maintainer}=
- defined($maintainer{$_}) ? $maintainer{$_} :
- length($_) ? "(unknown -- \`$_')" :
- "(unknown)";
- if ($mode eq 'undone' || $mode eq 'veryold') {
- &unfilelock;
- next if length($data->{done}) || length($data->{forwarded});
- $cmonths= int(($startdate - $data->{date})/2592000); # 3600*24*30 (30 days)
- next if $mode eq 'veryold' && $cmonths < 2;
- if ($cmonths != $amonths) {
- $msg= $cmonths == 0 ? "Submitted in the last month" :
- $cmonths == 1 ? "Over one month old" :
- $cmonths == 2 ? "Over two months old - attention is required" :
- "OVER $cmonths MONTHS OLD - ATTENTION IS REQUIRED";
- print "\n$msg:\n$head\n";
- $amonths= $cmonths;
- }
- printf("%6d %-10.10s %-30.30s %-.31s\n", $f, $data->{package},
- (length($data->{keywords}) ? $data->{keywords}.'/' : '').$data->{subject},
- $data->{maintainer}) || &quit("output undone: $!");
- } elsif ($mode eq 'bymaint') {
- &unfilelock;
- next if length($data->{done}) || length($data->{forwarded});
- $string{$f}=
- sprintf(" %-10.10s %6d %-.59s\n", $data->{package}, $f, $data->{subject});
- $data->{maintainer}= "(unknown)" if $data->{maintainer} =~ m/^\(unknown \-\-/;
- $maintainercnt{$data->{maintainer}}++;
- $maintainerlist{$data->{maintainer}}.= " $f";
- } else {
- &quit("badmode $mode");
- }
-}
-
-if ($mode eq 'bymaint') {
- print("$head\n") || &quit("output head: $!");
- for $m (sort { $maintainercnt{$a} <=> $maintainercnt{$b} } keys %maintainercnt) {
- printf("\n%s (%d $gBugs):\n",$m,$maintainercnt{$m})
- || &quit("output mainthead: $!");
- for $i (sort { $string{$a} cmp $string{$b} } split(/ /,$maintainerlist{$m})) {
- printf($string{$i}) || &quit("output 1bymaint: $!");
- }
- }
-}
-
-close(STDOUT) || &quit("close stdout: $!");
--- /dev/null
+# -*- mode: cperl -*-
+
+use Debbugs::Config qw(:globals);
+
+############################################################################
+# Here is a blurb to point people to ftp archive of directions. It is
+# used by the receive script when bouncing a badly formatted email
+#
+# $gTextInstructions = "$gBadEmailPrefix
+# $gBadEmailPrefix Instructions are available from ftp.debian.org in /debian
+# $gBadEmailPrefix and at all Debian mirror sites, in the files:
+# $gBadEmailPrefix doc/bug-reporting.txt
+# $gBadEmailPrefix doc/bug-log-access.txt
+# $gBadEmailPrefix doc/bug-maint-info.txt
+# $gBadEmailPrefix";
+############################################################################
+$gBadEmailPrefix = '' unless defined $gBadEmailPrefix;
+$gTextInstructions = "$gBadEmailPrefix";
+
+
+############################################################################
+# Here is a blurb for any mirrors of the web site. Here's a sample:
+#
+#$gHTMLCopies = "<p>Copies of the logs are available on the World Wide Web at<BR>
+# <A HREF=\"http://mirror1.domain\"><CODE>http://mirror1.domain</CODE></A><BR>
+# <A HREF=\"http://mirror2.domain\"><CODE>http://mirror2.domain</CODE></A>";
+############################################################################
+$gHTMLCopies = "";
+
+
+############################################################################
+# notice other links you want to note, like your list archives or project
+# home page.
+#
+#$gHTMLOtherPages = "Other Links of note:<BR>
+# <A HREF=\"http://www.debian.org/\">The Debian Project</A><BR>
+# <A HREF=\"http://another.domain\">Description of URL</A>";
+############################################################################
+$gHTMLOtherPages = "";
+
+
+############################################################################
+# list of other links you want to note, like your list archives or project
+# home page. Some pages already have links in a list, this adds them to
+# the end of the list.
+#
+#$gHTMLOtherPageList = "<LI><A HREF=\"http://www.debian.org/\">
+# The Debian Project</A>
+# <LI><A HREF=\"http://another.domain\">Description of URL</A>";
+############################################################################
+$gHTMLOtherPageList = "";
+
+
+############################################################################
+# gives explanation of bad maintainer situation and instructions on how to
+# correct.
+############################################################################
+$gBadMaintHtml = "";
+
+
+############################################################################
+# give directions here for how to find the proper title for Package:
+# pseudo header line.
+############################################################################
+$gHTMLFindPackage = "";
+
+
+############################################################################
+# If you have pseudo packages, place a blurb here. For example:
+# $gHTMLPseudoDesc = "<p>There are some pseudo-packages available for putting in
+# the <CODE>Package</CODE> line when reporting a $gBug in something other than an
+# actual $gProject software package. There is
+# <A HREF="db/ix/pseudopackages.html"> a list of these</A> on the $gBugs WWW
+# pages.";
+############################################################################
+$gHTMLPseudoDesc = "";
+
+
+############################################################################
+# List any extra information you would like included in bug reports. For
+# example:
+# $gXtraBugInfo = "<li>What kernel version you're using (type
+# <code>uname -a</code>), your shared C library (type <code>ls -l
+# /lib/libc.so.6</code> or <code>dpkg -s libc6 | grep ^Version</code>), and
+# any other details about your Debian system, if it seems appropriate.
+# For example, if you had a problem with a Perl script, you would want to
+# provide the version of the `perl' binary (type <code>perl -v</code> or
+# <code>dpkg -s perl-5.005 | grep ^Version:</code>).";
+############################################################################
+$gXtraBugInfo = "";
+
+
+############################################################################
+# List any extra information you would like about reporting bugs
+############################################################################
+$gXtraReportingInfo = "";
+
+
+############################################################################
+# Process used by system to create Maintainers index file
+############################################################################
+$gCreateMaintainers = "";
+
+
+###########################################################################
+# You shouldn't have to modify anything below here unless it's for personal
+# preference. Be very careful and don't touch unless you *know* what
+# you're doing. Much of the stuff has hardcoded duplicates elsewhere.
+
+
+############################################################################
+# Description of the severities
+############################################################################
+$gHTMLSeverityDesc = "<DT><CODE>critical</CODE>
+ <DD>makes unrelated software on the system (or the whole system) break,
+ or causes serious data loss, or introduces a security hole on systems
+ where you install the package.
+
+ <DT><CODE>grave</CODE>
+ <DD>makes the package in question unusable or mostly so, or causes data
+ loss, or introduces a security hole allowing access to the accounts of
+ users who use the package.
+
+ <DT><CODE>normal</CODE>
+ <DD>the default value, for normal $gBugs.
+
+ <DT><CODE>wishlist</CODE>
+ <DD>for any feature request, and also for any $gBugs that are very
+ difficult to fix due to major design considerations.";
+
+############################################################################
+# Description of the tags
+############################################################################
+$gHTMLTagDesc = "
+<dt><code>patch</code>
+ <dd>A patch or some other easy procedure for fixing the $gBug is included in
+ the $gBug logs. If there\'s a patch, but it doesn\'t resolve the $gBug
+ adequately or causes some other problems, this tag should not be used.
+
+<dt><code>wontfix</code>
+ <dd>This $gBug won\'t be fixed. Possibly because this is a choice between two
+ arbitrary ways of doing things and the maintainer and submitter prefer
+ different ways of doing things, possibly because changing the behaviour
+ will cause other, worse, problems for others, or possibly for other
+ reasons.
+
+<dt><code>moreinfo</code>
+ <dd>This $gBug can\'t be addressed until more information is provided by the
+ submitter. The $gBug will be closed if the submitter doesn\'t provide more
+ information in a reasonable (few months) timeframe. This is for $gBugs like
+ \"It doesn\'t work\". What doesn\'t work?
+
+<dt><code>unreproducible</code>
+ <dd>This $gBug can\'t be reproduced on the maintainer\'s system. Assistance
+ from third parties is needed in diagnosing the cause of the problem.
+
+<dt><code>fixed</code>
+ <dd>This $gBug is fixed or worked around, but there\'s still an issue that
+ needs to be resolved.
+
+<dt><code>stable</code>
+ <dd>This $gBug affects the stable distribution in particular. This is only
+ intended to be used for ease in identifying release critical $gBugs that
+ affect the stable distribution. It\'ll be replaced eventually with
+ something a little more flexible, probably.
+";
+
+############################################################################
+# shows up at the start of (most) html pages.
+############################################################################
+$gHTMLStart = "<BODY>";
+
+############################################################################
+# shows up at the end of (most) html pages.
+############################################################################
+$gHTMLTail = "
+ <ADDRESS>$gMaintainer <<A HREF=\"mailto:$gMaintainerEmail\">$gMaintainerEmail</A>>.
+ Last modified:
+ <!--timestamp-->
+ SUBSTITUTE_DTIME
+ <!--timestamp-->
+
+ <P>
+ <A HREF=\"http://$gWebDomain/\">Debian $gBug tracking system</A><BR>
+ Copyright (C) 1999 Darren O. Benham,
+ 1997,2003 nCipher Corporation Ltd,
+ 1994-97 Ian Jackson.
+ </ADDRESS>
+";
+
+############################################################################
+# Message on when reports are purged.
+############################################################################
+$gHTMLExpireNote = "(Closed $gBugs are archived $gRemoveAge days after the last related message is received.)";
+
+############################################################################
+# Makeup of the stamp page
+############################################################################
+$gHTMLStamp = "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">
+ <HTML><HEAD><TITLE>$gProject $gBugs - timestamp page</TITLE>
+ <LINK REV=\"made\" HREF=\"mailto:$gMaintainerEmail\">
+ </HEAD>$gHTMLStart<H1>Is this $gBug log or mirror up to date?</H1>
+
+ Unlike all the other $gBug pages, this small timestamp page is updated every
+ time the update check job runs. If the timestamp here is recent it\'s
+ likely that the mirror in which you\'re reading it is up to date.
+ <P>
+ The last
+ <!--updateupdate-->update<!--/updateupdate-->
+ was at
+ <STRONG><!--updatetime-->SUBSTITUTE_DTIME<!--/updatetime--></STRONG>;
+ The logs are usually checked every hour and updated if necessary.
+ <P>
+ For the $gBug index or for other information about $gProject and the $gBug
+ system, see the <A HREF=\"../../\">$gBug system main contents page</A>.
+
+ <HR>
+ <ADDRESS>
+ <A HREF=\"mailto:$gMaintainerEmail\">$gMaintainerEmail</A>,
+ through the <A HREF=\"../../\">$gProject $gBug database</a>
+ </ADDRESS>
+ <!--version 1.0-4.3-->";
+
+############################################################################
+# Makeup of the indices pages
+############################################################################
+$gFullIndex = "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">
+ <HTML><HEAD><TITLE>$gProject $gBugs - full index</TITLE>
+ <LINK REV=\"make\" HREF=\"mailto:$gMaintainerEmail\">
+ </HEAD>$gHTMLStart<H1>$gProject $gBug report logs - index</H1>
+
+ This index gives access to $gBugs sent to <CODE>submit\@$gEmailDomain</CODE>
+ but not yet marked as done, and to $gBugs marked as done but not yet purged
+ from the database (this happens $gRemoveAge days after the last message relating to
+ the report).
+ <P>
+ For other kinds of indices or for other information about $gProject and
+ the $gBug system, see <A HREF=\"../../\">$gBug system top-level contents WWW
+ page</A>.
+
+
+ ";
+
+$gJunkIndex = "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">
+ <HTML><HEAD><TITLE>$gProject $gBug reports - Junk</TITLE>
+ <LINK REV=\"made\" HREF=\"$gMaintainerEmail\">
+ </HEAD>$gHTMLStart<H1>$gProject $gBug reports - Junk</H1>
+
+ This is the index page for logs of messages not associated with a specific
+ $gBug report.
+ <P>
+ For other kinds of indices or for other information about $gProject and
+ the $gBug system, see <A HREF=\"../../\">$gBug system top-level contents WWW
+ page</A>.
+
+
+ ";
+
+$gMaintIndex = "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">
+ <HTML><HEAD><TITLE>$gProject $gBug reports by maintainer</TITLE>
+ <LINK REF=\"made\" HREF=\"mailto:$gMaintainerEmail\">
+ </HEAD>$gHTMLStart<H1>$gProject $gBug reports by maintainer</H1>
+
+ This page lists the package maintainers against whose packages there are
+ outstanding, forwarded or recently-closed $gBug reports. A maintainer who
+ has several versions of their email address in the <CODE>Maintainer</CODE>
+ package control file field may appear several times.<P>
+ If the maintainers information here is not accurate, please see
+ <A HREF=\"../../Developer.html#maintincorrect\">the developers\'
+ instructions</A> to find how this can happen and what to do about it. <P>
+ For other kinds of indices or for other information about $gProject and
+ the $gBug system, see <A HREF=\"../../\">$gBug system top-level contents WWW
+ page</A>.
+
+
+ ";
+
+$gPackageIndex = "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">
+ <HTML><HEAD><TITLE>$gProject $gBug reports by package</TITLE>
+ <LINK REF=\"made\" HREF=\"mailto:$gMaintainerEmail\">
+ </HEAD>$gHTMLStart<H1>$gProject $gBug reports by package</H1>
+
+ This page lists the package against which there are outstanding, forwarded or
+ recently-closed $gBug reports. A multi-binary package may appear several
+ times, once for each binary package name and once for the source package
+ name (if it is different).<P>
+ For other kinds of indices or for other information about $gProject and
+ the $gBug system, see <A HREF=\"../../\">$gBug system top-level contents WWW
+ page</A>.
+
+
+ ";
+
+$gSummaryIndex = "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">
+ <HTML><HEAD><TITLE>$gProject $gBug report logs - summary index</TITLE>
+ <LINK REF=\"made\" HREF=\"mailto:$gMaintainerEmail\">
+ </HEAD>$gHTMLStart<H1>$gProject $gBug report logs - summary index</H1>
+
+ This summary index briefly lists $gBugs sent to <CODE>submit\@$gEmailDomain
+ </CODE> but not yet marked as done, or as forwarded to an upstream author.
+ Here they are sorted by reference number (and therefore by submission date,
+ too).<P>
+ For other kinds of indices or for other information about $gProject and
+ the $gBug system, see <A HREF=\"../../\">$gBug system top-level contents WWW
+ page</A>.
+
+ <P>The * column lists the first letter of the severity of the $gBug.
+
+
+ ";
+
+$gPackageLog = "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">
+ <HTML><HEAD><TITLE>$gProject $gBug report logs - index by package</TITLE>
+ <LINK REF=\"made\" HREF=\"mailto:$gMaintainerEmail\">
+ </HEAD>$gHTMLStart<H1>$gProject $gBug report logs - index by package</H1>
+
+ This summary index briefly lists $gBugs sent to <CODE>submit\@$gEmailDomain
+ </CODE> but not yet marked as done, or as forwarded to an upstream author.
+ Here they are sorted by package name.<P>
+ For other kinds of indices or for other information about $gProject and
+ the $gBug system, see <A HREF=\"../../\">$gBug system top-level contents WWW
+ page</A>.
+
+
+ ";
+
+$gPseudoIndex = "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">
+ <HTML><HEAD><TITLE>$gProject $gBug report pseudo-packages</TITLE>
+ <LINK REF=\"made\" HREF=\"mailto:$gMaintainerEmail\">
+ </HEAD>$gHTMLStart<H1>$gProject $gBug report pseudo-packages</H1>
+
+ This page lists the pseudo-packages available for use in the
+ <CODE>Package:</CODE> line in $gBug reports.<P>
+
+ See the <A HREF=\"../../Reporting.html\">instructions for reporting a
+ $gBug</A> for details of how to specify a <CODE>Package:</CODE> line.<P>
+ For other kinds of indices or for other information about $gProject and
+ the $gBug system, see <A HREF=\"../../\">$gBug system top-level contents WWW
+ page</A>.
+
+
+ ";
+++ /dev/null
-# -*- mode: cperl -*-
-
-use Debbugs::Config qw(:globals);
-
-############################################################################
-# Here is a blurb to point people to ftp archive of directions. It is
-# used by the receive script when bouncing a badly formatted email
-#
-# $gTextInstructions = "$gBadEmailPrefix
-# $gBadEmailPrefix Instructions are available from ftp.debian.org in /debian
-# $gBadEmailPrefix and at all Debian mirror sites, in the files:
-# $gBadEmailPrefix doc/bug-reporting.txt
-# $gBadEmailPrefix doc/bug-log-access.txt
-# $gBadEmailPrefix doc/bug-maint-info.txt
-# $gBadEmailPrefix";
-############################################################################
-$gBadEmailPrefix = '' unless defined $gBadEmailPrefix;
-$gTextInstructions = "$gBadEmailPrefix";
-
-
-############################################################################
-# Here is a blurb for any mirrors of the web site. Here's a sample:
-#
-#$gHTMLCopies = "<p>Copies of the logs are available on the World Wide Web at<BR>
-# <A HREF=\"http://mirror1.domain\"><CODE>http://mirror1.domain</CODE></A><BR>
-# <A HREF=\"http://mirror2.domain\"><CODE>http://mirror2.domain</CODE></A>";
-############################################################################
-$gHTMLCopies = "";
-
-
-############################################################################
-# notice other links you want to note, like your list archives or project
-# home page.
-#
-#$gHTMLOtherPages = "Other Links of note:<BR>
-# <A HREF=\"http://www.debian.org/\">The Debian Project</A><BR>
-# <A HREF=\"http://another.domain\">Description of URL</A>";
-############################################################################
-$gHTMLOtherPages = "";
-
-
-############################################################################
-# list of other links you want to note, like your list archives or project
-# home page. Some pages already have links in a list, this adds them to
-# the end of the list.
-#
-#$gHTMLOtherPageList = "<LI><A HREF=\"http://www.debian.org/\">
-# The Debian Project</A>
-# <LI><A HREF=\"http://another.domain\">Description of URL</A>";
-############################################################################
-$gHTMLOtherPageList = "";
-
-
-############################################################################
-# gives explanation of bad maintainer situation and instructions on how to
-# correct.
-############################################################################
-$gBadMaintHtml = "";
-
-
-############################################################################
-# give directions here for how to find the proper title for Package:
-# pseudo header line.
-############################################################################
-$gHTMLFindPackage = "";
-
-
-############################################################################
-# If you have pseudo packages, place a blurb here. For example:
-# $gHTMLPseudoDesc = "<p>There are some pseudo-packages available for putting in
-# the <CODE>Package</CODE> line when reporting a $gBug in something other than an
-# actual $gProject software package. There is
-# <A HREF="db/ix/pseudopackages.html"> a list of these</A> on the $gBugs WWW
-# pages.";
-############################################################################
-$gHTMLPseudoDesc = "";
-
-
-############################################################################
-# List any extra information you would like included in bug reports. For
-# example:
-# $gXtraBugInfo = "<li>What kernel version you're using (type
-# <code>uname -a</code>), your shared C library (type <code>ls -l
-# /lib/libc.so.6</code> or <code>dpkg -s libc6 | grep ^Version</code>), and
-# any other details about your Debian system, if it seems appropriate.
-# For example, if you had a problem with a Perl script, you would want to
-# provide the version of the `perl' binary (type <code>perl -v</code> or
-# <code>dpkg -s perl-5.005 | grep ^Version:</code>).";
-############################################################################
-$gXtraBugInfo = "";
-
-
-############################################################################
-# List any extra information you would like about reporting bugs
-############################################################################
-$gXtraReportingInfo = "";
-
-
-############################################################################
-# Process used by system to create Maintainers index file
-############################################################################
-$gCreateMaintainers = "";
-
-
-###########################################################################
-# You shouldn't have to modify anything below here unless it's for personal
-# preference. Be very careful and don't touch unless you *know* what
-# you're doing. Much of the stuff has hardcoded duplicates elsewhere.
-
-
-############################################################################
-# Description of the severities
-############################################################################
-$gHTMLSeverityDesc = "<DT><CODE>critical</CODE>
- <DD>makes unrelated software on the system (or the whole system) break,
- or causes serious data loss, or introduces a security hole on systems
- where you install the package.
-
- <DT><CODE>grave</CODE>
- <DD>makes the package in question unusable or mostly so, or causes data
- loss, or introduces a security hole allowing access to the accounts of
- users who use the package.
-
- <DT><CODE>normal</CODE>
- <DD>the default value, for normal $gBugs.
-
- <DT><CODE>wishlist</CODE>
- <DD>for any feature request, and also for any $gBugs that are very
- difficult to fix due to major design considerations.";
-
-############################################################################
-# Description of the tags
-############################################################################
-$gHTMLTagDesc = "
-<dt><code>patch</code>
- <dd>A patch or some other easy procedure for fixing the $gBug is included in
- the $gBug logs. If there\'s a patch, but it doesn\'t resolve the $gBug
- adequately or causes some other problems, this tag should not be used.
-
-<dt><code>wontfix</code>
- <dd>This $gBug won\'t be fixed. Possibly because this is a choice between two
- arbitrary ways of doing things and the maintainer and submitter prefer
- different ways of doing things, possibly because changing the behaviour
- will cause other, worse, problems for others, or possibly for other
- reasons.
-
-<dt><code>moreinfo</code>
- <dd>This $gBug can\'t be addressed until more information is provided by the
- submitter. The $gBug will be closed if the submitter doesn\'t provide more
- information in a reasonable (few months) timeframe. This is for $gBugs like
- \"It doesn\'t work\". What doesn\'t work?
-
-<dt><code>unreproducible</code>
- <dd>This $gBug can\'t be reproduced on the maintainer\'s system. Assistance
- from third parties is needed in diagnosing the cause of the problem.
-
-<dt><code>fixed</code>
- <dd>This $gBug is fixed or worked around, but there\'s still an issue that
- needs to be resolved.
-
-<dt><code>stable</code>
- <dd>This $gBug affects the stable distribution in particular. This is only
- intended to be used for ease in identifying release critical $gBugs that
- affect the stable distribution. It\'ll be replaced eventually with
- something a little more flexible, probably.
-";
-
-############################################################################
-# shows up at the start of (most) html pages.
-############################################################################
-$gHTMLStart = "<BODY>";
-
-############################################################################
-# shows up at the end of (most) html pages.
-############################################################################
-$gHTMLTail = "
- <ADDRESS>$gMaintainer <<A HREF=\"mailto:$gMaintainerEmail\">$gMaintainerEmail</A>>.
- Last modified:
- <!--timestamp-->
- SUBSTITUTE_DTIME
- <!--timestamp-->
-
- <P>
- <A HREF=\"http://$gWebDomain/\">Debian $gBug tracking system</A><BR>
- Copyright (C) 1999 Darren O. Benham,
- 1997,2003 nCipher Corporation Ltd,
- 1994-97 Ian Jackson.
- </ADDRESS>
-";
-
-############################################################################
-# Message on when reports are purged.
-############################################################################
-$gHTMLExpireNote = "(Closed $gBugs are archived $gRemoveAge days after the last related message is received.)";
-
-############################################################################
-# Makeup of the stamp page
-############################################################################
-$gHTMLStamp = "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">
- <HTML><HEAD><TITLE>$gProject $gBugs - timestamp page</TITLE>
- <LINK REV=\"made\" HREF=\"mailto:$gMaintainerEmail\">
- </HEAD>$gHTMLStart<H1>Is this $gBug log or mirror up to date?</H1>
-
- Unlike all the other $gBug pages, this small timestamp page is updated every
- time the update check job runs. If the timestamp here is recent it\'s
- likely that the mirror in which you\'re reading it is up to date.
- <P>
- The last
- <!--updateupdate-->update<!--/updateupdate-->
- was at
- <STRONG><!--updatetime-->SUBSTITUTE_DTIME<!--/updatetime--></STRONG>;
- The logs are usually checked every hour and updated if necessary.
- <P>
- For the $gBug index or for other information about $gProject and the $gBug
- system, see the <A HREF=\"../../\">$gBug system main contents page</A>.
-
- <HR>
- <ADDRESS>
- <A HREF=\"mailto:$gMaintainerEmail\">$gMaintainerEmail</A>,
- through the <A HREF=\"../../\">$gProject $gBug database</a>
- </ADDRESS>
- <!--version 1.0-4.3-->";
-
-############################################################################
-# Makeup of the indices pages
-############################################################################
-$gFullIndex = "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">
- <HTML><HEAD><TITLE>$gProject $gBugs - full index</TITLE>
- <LINK REV=\"make\" HREF=\"mailto:$gMaintainerEmail\">
- </HEAD>$gHTMLStart<H1>$gProject $gBug report logs - index</H1>
-
- This index gives access to $gBugs sent to <CODE>submit\@$gEmailDomain</CODE>
- but not yet marked as done, and to $gBugs marked as done but not yet purged
- from the database (this happens $gRemoveAge days after the last message relating to
- the report).
- <P>
- For other kinds of indices or for other information about $gProject and
- the $gBug system, see <A HREF=\"../../\">$gBug system top-level contents WWW
- page</A>.
-
-
- ";
-
-$gJunkIndex = "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">
- <HTML><HEAD><TITLE>$gProject $gBug reports - Junk</TITLE>
- <LINK REV=\"made\" HREF=\"$gMaintainerEmail\">
- </HEAD>$gHTMLStart<H1>$gProject $gBug reports - Junk</H1>
-
- This is the index page for logs of messages not associated with a specific
- $gBug report.
- <P>
- For other kinds of indices or for other information about $gProject and
- the $gBug system, see <A HREF=\"../../\">$gBug system top-level contents WWW
- page</A>.
-
-
- ";
-
-$gMaintIndex = "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">
- <HTML><HEAD><TITLE>$gProject $gBug reports by maintainer</TITLE>
- <LINK REF=\"made\" HREF=\"mailto:$gMaintainerEmail\">
- </HEAD>$gHTMLStart<H1>$gProject $gBug reports by maintainer</H1>
-
- This page lists the package maintainers against whose packages there are
- outstanding, forwarded or recently-closed $gBug reports. A maintainer who
- has several versions of their email address in the <CODE>Maintainer</CODE>
- package control file field may appear several times.<P>
- If the maintainers information here is not accurate, please see
- <A HREF=\"../../Developer.html#maintincorrect\">the developers\'
- instructions</A> to find how this can happen and what to do about it. <P>
- For other kinds of indices or for other information about $gProject and
- the $gBug system, see <A HREF=\"../../\">$gBug system top-level contents WWW
- page</A>.
-
-
- ";
-
-$gPackageIndex = "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">
- <HTML><HEAD><TITLE>$gProject $gBug reports by package</TITLE>
- <LINK REF=\"made\" HREF=\"mailto:$gMaintainerEmail\">
- </HEAD>$gHTMLStart<H1>$gProject $gBug reports by package</H1>
-
- This page lists the package against which there are outstanding, forwarded or
- recently-closed $gBug reports. A multi-binary package may appear several
- times, once for each binary package name and once for the source package
- name (if it is different).<P>
- For other kinds of indices or for other information about $gProject and
- the $gBug system, see <A HREF=\"../../\">$gBug system top-level contents WWW
- page</A>.
-
-
- ";
-
-$gSummaryIndex = "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">
- <HTML><HEAD><TITLE>$gProject $gBug report logs - summary index</TITLE>
- <LINK REF=\"made\" HREF=\"mailto:$gMaintainerEmail\">
- </HEAD>$gHTMLStart<H1>$gProject $gBug report logs - summary index</H1>
-
- This summary index briefly lists $gBugs sent to <CODE>submit\@$gEmailDomain
- </CODE> but not yet marked as done, or as forwarded to an upstream author.
- Here they are sorted by reference number (and therefore by submission date,
- too).<P>
- For other kinds of indices or for other information about $gProject and
- the $gBug system, see <A HREF=\"../../\">$gBug system top-level contents WWW
- page</A>.
-
- <P>The * column lists the first letter of the severity of the $gBug.
-
-
- ";
-
-$gPackageLog = "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">
- <HTML><HEAD><TITLE>$gProject $gBug report logs - index by package</TITLE>
- <LINK REF=\"made\" HREF=\"mailto:$gMaintainerEmail\">
- </HEAD>$gHTMLStart<H1>$gProject $gBug report logs - index by package</H1>
-
- This summary index briefly lists $gBugs sent to <CODE>submit\@$gEmailDomain
- </CODE> but not yet marked as done, or as forwarded to an upstream author.
- Here they are sorted by package name.<P>
- For other kinds of indices or for other information about $gProject and
- the $gBug system, see <A HREF=\"../../\">$gBug system top-level contents WWW
- page</A>.
-
-
- ";
-
-$gPseudoIndex = "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">
- <HTML><HEAD><TITLE>$gProject $gBug report pseudo-packages</TITLE>
- <LINK REF=\"made\" HREF=\"mailto:$gMaintainerEmail\">
- </HEAD>$gHTMLStart<H1>$gProject $gBug report pseudo-packages</H1>
-
- This page lists the pseudo-packages available for use in the
- <CODE>Package:</CODE> line in $gBug reports.<P>
-
- See the <A HREF=\"../../Reporting.html\">instructions for reporting a
- $gBug</A> for details of how to specify a <CODE>Package:</CODE> line.<P>
- For other kinds of indices or for other information about $gProject and
- the $gBug system, see <A HREF=\"../../\">$gBug system top-level contents WWW
- page</A>.
-
-
- ";
Subject => "Munging a bug with $command",
],
body => <<EOF) or fail 'message to control@bugs.something failed';
+debug 10
$control_command->{command} 1$control_command->{value}
thanks
EOF
$mech->get_ok('http://localhost:'.$port.'/?bug=1',
'Page received ok');
-ok($mech->content() =~ qr/\<title\>\#1\s+\-\s+Submitting a bug/i,
+ok($mech->content() =~ qr/\<title\>\#1.+Submitting a bug/i,
'Title of bug is submitting a bug');
# Other tests for bugs in the page should be added here eventually
+
use warnings;
use strict;
-# Here, we're going to shoot messages through a set of things that can
-# happen.
-
-# First, we're going to send mesages to receive.
-# To do so, we'll first send a message to submit,
-# then send messages to the newly created bugnumber.
-
use IO::File;
use File::Temp qw(tempdir);
use Cwd qw(getcwd);
BAIL_OUT($@);
}
-# Output some debugging information if there's an error
+# Output some debugging information if we're debugging
END{
if ($ENV{DEBUG}) {
foreach my $key (keys %config) {
EOF
-# test bugreport.cgi
+# test the soap server
my $port = 11343;
END{
if (defined $child_pid) {
+ my $temp_exit = $?;
kill(15,$child_pid);
waitpid(-1,0);
+ $? = $temp_exit;
}
}
my $output='';
local $SIG{PIPE} = 'IGNORE';
local $SIG{CHLD} = sub {};
- my $pid = open3($wfd,$rfd,$rfd,'scripts/receive.in')
- or die "Unable to start receive.in: $!";
+ my $pid = open3($wfd,$rfd,$rfd,'scripts/receive')
+ or die "Unable to start receive: $!";
print {$wfd} create_mime_message($param{headers},
- $param{body}) or die "Unable to to print to receive.in";
- close($wfd) or die "Unable to close receive.in";
+ $param{body}) or die "Unable to to print to receive";
+ close($wfd) or die "Unable to close receive";
my $err = $? >> 8;
my $childpid = waitpid($pid,0);
if ($childpid != -1) {
$err = $? >> 8;
- print STDERR "receive.in pid: $pid doesn't match childpid: $childpid\n" if $childpid != $pid;
+ print STDERR "receive pid: $pid doesn't match childpid: $childpid\n" if $childpid != $pid;
}
if ($err != 0 ) {
my $rfh = IO::Handle->new_from_fd($rfd,'r') or die "Unable to create filehandle: $!";
print STDERR "Reading from STDOUT/STDERR would have blocked.";
}
print STDERR $output,qq(\n);
- die "receive.in failed with exit status $err";
+ die "receive failed with exit status $err";
}
# now we should run processall to see if the message gets processed
if ($param{run_processall}) {
- system('scripts/processall.in') == 0 or die "processall.in failed";
+ system('scripts/processall') == 0 or die "processall failed";
}
}
END {
if (defined $child_pid) {
# stop the child
+ my $temp_exit = $?;
kill(15,$child_pid);
waitpid(-1,0);
+ $? = $temp_exit;
}
}
--- /dev/null
+{include(q(html/pre_title))}#{$bug_num} - {html_escape($status{subject})} - {html_escape($config{project})} {html_escape($config{bug})} report logs{include(q(html/post_title.tmpl))}
+<script type="text/javascript">
+<!--
+function toggle_infmessages()
+\{
+ allDivs=document.getElementsByTagName("div");
+ for (var i = 0 ; i < allDivs.length ; i++ )
+ \{
+ if (allDivs[i].className == "infmessage")
+ \{
+ allDivs[i].style.display=(allDivs[i].style.display == 'none' | allDivs[i].style.display == '') ? 'block' : 'none';
+ \}
+ \}
+\}
+-->
+</script>
+</head>
+<body>
+<h1>{html_escape($config{project})} {html_escape($config{bug})} report logs -
+<a href="mailto:{$bug_num}@{html_escape($config{email_domain})}">#{$bug_num}</a><br/>
+{html_escape($status{subject})}</h1>
+<div class="versiongraph">{$version_graph}</div>
+{include(q(cgi/bugreport_pkginfo))}
+{include(q(cgi/bugreport_buginfo))}
+{ my $output = '';
+ if (looks_like_number($msg)) {
+ $output .= sprintf qq(<p><a href="%s">Full log</a></p>),html_escape(bug_links(bug=>$ref,links_only=>1));
+ }
+ else {
+ $output .= qq(<p><a href="mailto:$bug_num\@$config{email_domain}">Reply</a> ).
+ qq(or <a href="mailto:$bug_num-subscribe\@$config{email_domain}">subscribe</a> ).
+ qq(to this bug.</p>\n);
+ $output .= qq(<p><a href="javascript:toggle_infmessages();">Toggle useless messages</a></p>);
+ $output .= sprintf qq(<div class="msgreceived"><p>View this report as an <a href="%s">mbox folder</a>, ).
+ qq(<a href="%s">status mbox</a>, <a href="%s">maintainer mbox</a></p></div>\n),
+ html_escape(bug_links(bug=>$bug_num, links_only=>1,options=>{mbox=>'yes'})),
+ html_escape(bug_links(bug=>$bug_num, links_only=>1,options=>{mbox=>'yes',mboxstatus=>'yes'})),
+ html_escape(bug_links(bug=>$bug_num, links_only=>1,options=>{mbox=>'yes',mboxmaint=>'yes'}));
+ }
+ $output;
+}
+{$log}
+<hr>
+<p class="msgreceived">Send a report that <a href="{$config{cgi_domain}}/bugspam.cgi">this bug log contains spam</a>.</p>
+<hr>
+{include(q(html/html_tail))}
+</body>
+</html>
--- /dev/null
+<div class="buginfo">
+ <p>Reported by: {package_links(submitter=>$status{originator})}</p>
+ <p>Date: {$status{date_text}}</p>
+{ my $output = '';
+ if (defined $status{owner} and length $status{owner}) {
+ $output = q(<p>Owned by: ).package_links(owner=>$status{owner}).q(</p>);
+ }
+ $output;
+}
+<p>Severity: {my $output = $status{severity};
+ if (isstrongseverity($status{severity})) {
+ $output = q(<em class="severity">).$status{severity}.q(</em>);
+ }
+ $output;
+ }</p>
+<p>{@{$status{tags_array}}?q(Tags: ).html_escape(join(q(, ),@{$status{tags_array}})):''}</p>
+{my $output = '';
+ if (@{$status{mergedwith_array}}) {
+ $output .= q(<p>Merged with ).join(qq(,\n),bug_links(bug=>$status{mergedwith_array})).qq(</p>\n);
+ }
+ $output;
+}
+{my $output = '';
+ if (@{$status{found_versions}}) {
+ $output .= q(<p>Found in );
+ $output .= (@{$status{found_versions}} == 1) ? 'version ' : 'versions ';
+ $output .= join(qq(, ),map {html_escape($_);} @{$status{found_versions}}).qq(</p>\n);
+ }
+ if (@{$status{fixed_versions}}) {
+ $output .= q(<p>Fixed in );
+ $output .= (@{$status{fixed_versions}} == 1) ? 'version ' : 'versions ';
+ $output .= join(qq(, ),map {html_escape($_);} @{$status{fixed_versions}}).qq(</p>\n);
+ }
+ $output;
+}
+{ my $output = '';
+ if (length($status{done})) {
+ $output .= q(<p><strong>Done:</strong> ).html_escape($status{done}).q(</p>)
+ }
+ $output;
+}
+{ my $output = '';
+ if (@{$status{blockedby_array}}) {
+ $output .= q(<p>Fix blocked by ).
+ join(q(, ),
+ map {bug_links(bug=>$_->{bug_num}).q(: ).html_escape($_->{subject})}
+ @{$status{blockedby_array}}).q(</p>)
+ }
+ if (@{$status{blocks_array}}) {
+ $output .= q(<p>Blocking fix for ).
+ join(q(, ),
+ map {bug_links(bug=>$_->{bug_num}).q(: ).html_escape($_->{subject})}
+ @{$status{blocks_array}}).q(</p>)
+ }
+ $output;
+}
+{ my $output = '';
+ if (exists $status{archived} and $status{archived}) {
+ $output .= q(<p>Bug is archived. No further changes may be made.<p>)
+ }
+ $output
+}</div>
--- /dev/null
+<div class="pkginfo">
+ <p>{if (keys %package > 1) { q(Packages)} else {q(Package)}}:
+ {join(q(, ),package_links(package => [map {$_->{package}} values %package],
+ class => q(submitter),
+ )
+ )};
+{my $output ='';
+ for my $package (values %package) {
+ $output .= q(Maintainer for ).package_links(package=>$package->{package}).qq( is ).
+ package_links(maintainer => $package->{maintainer}).qq(; );
+ $output .= q(Source for ).package_links(package=>$package->{package}).qq( is ).
+ package_links(source => $package->{source}).qq(. );
+ }
+ $output;
+}</p>
+</div>
--- /dev/null
+<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
+<html>
+<head><title>#{$bug_num} - {$config{project}} {$config{bug}} report logs</title></head>
+<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>
+{include('html/tail')}
+</body></html>
--- /dev/null
+<script type="text/javascript">
+<!--
+toggle_extra_status_visible();
+function pagemain() \{
+ toggle(1);
+// toggle(2);
+ enable(1);
+\}
+
+var visible_extra_status = 0;
+
+function toggle_extra_status_visible() \{
+ all_divs = document.getElementsByTagName("div");
+ for (var i = 0; i < all_divs.length; i++) \{
+ if (all_divs[i].className == "shortbugstatusextra") \{
+ if (all_divs[i].style.position == 'absolute' ) \{
+ all_divs[i].style.position = "static";
+ all_divs[i].style.display = "block";
+ all_divs[i].style.zIndex = 0;
+ all_divs[i].style.border = 0;
+ var subspans = all_divs[i].getElementsByTagName("span");
+ for (var j = 0; j < subspans.length; j++) \{
+ subspans[j].style.display = "inline";
+ \}
+ \}
+ else \{
+ all_divs[i].style.position = "absolute";
+ all_divs[i].style.display = "none"
+ all_divs[i].style.zIndex = 1;
+ all_divs[i].style.border = "#000 1px solid";
+ var subspans = all_divs[i].getElementsByTagName("span");
+ for (var j = 0; j < subspans.length; j++) \{
+ subspans[j].style.display = "block";
+ \}
+ \}
+ \}
+ \}
+\}
+
+function extra_status_visible(id) \{
+ if (visible_extra_status) \{
+ var t = document.getElementById("extra_status_"+visible_extra_status);
+ t.style.display = "none";
+ if (visible_extra_status == id) \{
+ visible_extra_status = 0;
+ return;
+ \}
+ visible_extra_status = 0;
+ \}
+ var e = document.getElementById("extra_status_"+id);
+ if (e) \{
+ e.style.display = "block";
+ visible_extra_status = id;
+ \}
+\}
+
+function setCookie(name, value, expires, path, domain, secure) \{
+ var curCookie = name + "=" + escape(value) +
+ ((expires) ? "; expires=" + expires.toGMTString() : "") +
+ ((path) ? "; path=" + path : "") +
+ ((domain) ? "; domain=" + domain : "") +
+ ((secure) ? "; secure" : "");
+ document.cookie = curCookie;
+\}
+
+function save_cat_cookies() \{
+ var cat = document.categories.categorisation.value;
+ var exp = new Date();
+ exp.setTime(exp.getTime() + 10 * 365 * 24 * 60 * 60 * 1000);
+ var oldexp = new Date();
+ oldexp.setTime(oldexp.getTime() - 1 * 365 * 24 * 60 * 60 * 1000);
+ var lev;
+ var done = 0;
+
+ var u = document.getElementById("users");
+ if (u != null) \{ u = u.value; \}
+ if (u == "") \{ u = null; \}
+ if (u != null) \{
+ setCookie("cat" + cat + "_users", u, exp, "/");
+ \} else \{
+ setCookie("cat" + cat + "_users", "", oldexp, "/");
+ \}
+
+ var bits = new Array("nam", "pri", "ttl", "ord");
+ for (var i = 0; i < 4; i++) \{
+ for (var j = 0; j < bits.length; j++) \{
+ var e = document.getElementById(bits[j] + i);
+ if (e) e = e.value;
+ if (e == null) \{ e = ""; \}
+ if (j == 0 && e == "") \{ done = 1; \}
+ if (done || e == "") \{
+ setCookie("cat" + cat + "_" + bits[j] + i, "", oldexp, "/");
+ \} else \{
+ setCookie("cat" + cat + "_" + bits[j] + i, e, exp, "/");
+ \}
+ \}
+ \}
+\}
+
+function toggle(i) \{
+ var a = document.getElementById("a_" + i);
+ if (a) \{
+ if (a.style.display == "none") \{
+ a.style.display = "";
+ \} else \{
+ a.style.display = "none";
+ \}
+ \}
+\}
+
+function enable(x) \{
+ for (var i = 1; ; i++) \{
+ var a = document.getElementById("b_" + x + "_" + i);
+ if (a == null) break;
+ var ischecked = a.checked;
+ for (var j = 1; ; j++) \{
+ var b = document.getElementById("b_" + x + "_"+ i + "_" + j);
+ if (b == null) break;
+ if (ischecked) \{
+ b.disabled = false;
+ \} else \{
+ b.disabled = true;
+ \}
+ \}
+ \}
+\}
+-->
+</script>
--- /dev/null
+<form method="GET">
+<input type="hidden" name="_fo_combine_key_fo_searchkey_value_fo_searchvalue" value="1">
+<input type="hidden" name="form_options" value="1">
+<table class="forms">
+<tr><td><h2>Select bugs</h2>
+</td>
+<td>
+{ my $output = '';
+our $value_index = 0;
+our $search = '';
+our $search_value = '';
+for my $key (@search_key_order){
+ if (exists $param{$key}){
+ for my $value (make_list($param{$key})){
+ $search = $key;
+ $search_value = $value;
+ $output .= include('cgi/pkgreport_options_search_key');
+ $output .= '<br>';
+ $value_index++;
+ }
+ }
+ }
+ $search = '';
+ $search_value = '';
+ $output;
+}
+{include('cgi/pkgreport_options_search_key')}
+</td>
+<td>
+<p>The same search fields are ORed, different fields are ANDed.</p>
+<p>Valid severities are {$config{show_severities}}</p>
+<p>Valid tags are {join(', ',@{$config{tags}})}</p>
+</td>
+</tr>
+<tr><td><h2>Include Bugs</h2></td>
+<td>{our $incexc = 'include';
+include('cgi/pkgreport_options_include_exclude');
+}</td>
+<td></td>
+</tr>
+<tr><td><h2>Exclude Bugs</h2></td>
+<td>
+{our $incexc = 'exclude';
+include('cgi/pkgreport_options_include_exclude');
+}
+</td>
+<td></td>
+</tr>
+<tr><td><h2>Categorize using</h2></td>
+<td></td>
+</tr>
+<tr><td><h2>Order by</h2></td>
+<td><select name="ordering">{ my $output = '';
+ my @orderings = qw(normal oldview raw age);
+ for my $order (@orderings) {
+ $output .= '<option value="'.$order.'"'.(($order eq $param{ordering})?' selected':'').
+ ">$order</option>\n";
+ }
+$output;
+}</td>
+<td></td>
+</tr>
+<tr><td><h2>Misc options</h2></td>
+<td>
+<input type="checkbox" name="repeatmerged" {exists $param{repeatmerged} and $param{repeatmerged}?' checked':''}> Repeat Merged<br>
+<input type="checkbox" name="bug-rev" {exists $param{"bug-rev"} and $param{"bug-rev"}?' checked':''}> Reverse Bugs<br>
+<input type="checkbox" name="pend-rev" {exists $param{"pend-rev"} and $param{"pend-rev"}?' checked':''}> Reverse Pending<br>
+<input type="checkbox" name="sev-rev" {exists $param{"sev-rev"} and $param{"sev-rev"}?' checked':''}> Reverse Severity<br>
+<select name="archive">
+{output_select_options([0 => 'Unarchived',
+ 1 => 'Archived',
+ both => 'Archived and Unarchived',
+ ],$param{archive}||0)
+}</select><br>
+<a href="javascript:toggle_extra_status_visible()">Toggle all extra information</a>
+</td>
+</tr>
+<tr><td><h2>Submit</h2></td><td colspan=2>
+<input type="submit" name="submit" value="Submit">
+</td></tr>
+</table>
+
+
--- /dev/null
+<input type="hidden" name="_fo_concatenate_into_{$incexc}_fo_{$incexc}key_fo_{$incexc}value" value="1">
+{ my $output = '';
+ our $value_index = 0;
+ our $key1 = '';
+ our $key2 = '';
+ for my $field (make_list($param{$incexc})) {
+ ($key1,$key2) = $field =~ m/^([^:]+)\:(.+)/;
+ next unless defined $key2;
+ $output .= include('cgi/pkgreport_options_include_exclude_key');
+ }
+ $key1 = '';
+ $key2 = '';
+ $output .= include('cgi/pkgreport_options_include_exclude_key');
+ $output;
+}
+
--- /dev/null
+<nobr><select name="_fo_{$incexc}key">
+{output_select_options([subject => 'with subject containing',
+ tags => 'tagged',
+ severity => 'with severity',
+ pending => 'with pending state',
+ originator => 'with submitter containing',
+ forwarded => 'with forwarded containing',
+ owner => 'with owner containing',
+ package => 'with package',
+ ],$key1||'')}
+</select>
+<input type="text" name="_fo_{$incexc}value" value ="{$key2||''}">
+<!-- {$value_index} -->
+</nobr>
--- /dev/null
+<nobr><select name="_fo_searchkey">
+{output_select_options(\@search_key_order,$search||'')}
+</select>
+<input type="text" name="_fo_searchvalue" value ="{$search_value||''}">
+<!-- {$value_index} -->
+</nobr>
--- /dev/null
+<HTML>
+<HEAD><TITLE>Error</TITLE></HEAD>
+<BODY>
+An error occurred.
+Error was: {$msg}
+</BODY></HTML>
--- /dev/null
+<div class="shortbugstatus">
+ <a href="{html_escape(bug_links(bug=>$status{bug_num},links_only=>1))}"{length($status{done})?' style="text-decoration:line-through"':''}>#{html_escape($status{bug_num})}</a>
+ [<font face="fixed"><a href="javascript:extra_status_visible({html_escape($status{bug_num})})">{
+ my $output = qq(<span title="$status{severity}">);
+ my $temp = $status{severity};
+ $temp = substr $temp,0,1;
+ if (isstrongseverity($status{severity})){
+ $temp = q(<em class="severity">).uc($temp).q(</em);
+ }
+ $output .= $temp.qq(</span>);
+ $output;
+ }|{
+ my $output = '';
+ for my $tag (@{$status{tags_array}}) {
+ next unless exists $config{tags_single_letter}{$tag};
+ $output .= q(<span title=").$tag.q(">).$config{tags_single_letter}{$tag}.q(</span>);
+ }
+ $output;
+ }|{
+ my $output = '';
+ if (@{$status{mergedwith_array}}) {
+ $output .= qq(<span title="merged">=</span>);
+ }
+ if (@{$status{fixed_versions}}) {
+ $output .= qq(<span title="fixed versions">☺</span>);
+ }
+ if (@{$status{blockedby_array}}) {
+ $output .= qq(<span title="blocked by">┫</span>);
+ }
+ if (@{$status{blocks_array}}) {
+ $output .= qq(<span title="blocks">┣</span>);
+ }
+ if (length($status{forwarded})) {
+ $output .= qq(<span title="forwarded">↝</span>);
+ }
+ if ($status{archived}) {
+ $output .= qq(<span title="archived">♲</span>);
+ }
+ $output;
+ }</a></font>]
+ [{package_links(package=>$status{package},options=>\%options,class=>"submitter")}]
+ <a href="{html_escape(bug_links(bug=>$status{bug_num},links_only=>1))}">{html_escape($status{subject})}</a>
+ <div id="extra_status_{html_escape($status{bug_num})}" class="shortbugstatusextra">
+ <span>Reported by: {package_links(submitter=>$status{originator})};</span>
+ <span>Date: {$status{date_text}};</span>
+{ my $output = '';
+ if (defined $status{owner} and length $status{owner}) {
+ $output = q(<span>Owned by: ).package_links(owner=>$status{owner}).q(;</span>);
+ }
+ $output;
+}
+<span>Severity: {my $output = $status{severity};
+ if (isstrongseverity($status{severity})) {
+ $output = q(<em class="severity">).$status{severity}.q(</em>);
+ }
+ $output;
+ };</span>
+<span>{@{$status{tags_array}}?q(Tags: ).html_escape(join(q(, ),@{$status{tags_array}})).';':''}</span>
+{my $output = '';
+ if (@{$status{mergedwith_array}}) {
+ $output .= q(<span>Merged with ).join(qq(,\n),bug_links(bug=>$status{mergedwith_array})).qq(;</span>\n);
+ }
+ $output;
+}
+{my $output = '';
+ if (@{$status{found_versions}} or @{$status{fixed_versions}}) {
+ $output .= '<a href="'.
+ version_url(package => $status{package},
+ found => $status{found_versions},
+ fixed => $status{fixed_versions},
+ ).'") ';
+ }
+ if (@{$status{found_versions}}) {
+ $output .= q(<span>Found in );
+ $output .= (@{$status{found_versions}} == 1) ? 'version ' : 'versions ';
+ $output .= join(qq(, ),map {html_escape($_);} @{$status{found_versions}}).qq(;</span>\n);
+ }
+ if (@{$status{fixed_versions}}) {
+ $output .= q(<span>Fixed in );
+ $output .= (@{$status{fixed_versions}} == 1) ? 'version ' : 'versions ';
+ $output .= join(qq(, ),map {html_escape($_);} @{$status{fixed_versions}}).qq(;</span>\n);
+ }
+ if (@{$status{found_versions}} or @{$status{fixed_versions}}) {
+ $output .= qq(</a>);
+ }
+ $output;
+}
+{ my $output = '';
+ if (length($status{done})) {
+ $output .= q(<span><strong>Done:</strong> ).html_escape($status{done}).q(;</span> )
+ }
+ $output;
+}
+{ my $output = '';
+ if (@{$status{blockedby_array}}) {
+ $output .= q(<span>Fix blocked by ).
+ join(q(, ),
+ map {bug_links(bug=>$_->{bug_num}).q(: ).html_escape($_->{subject})}
+ @{$status{blockedby_array}}).q(;</span> )
+ }
+ if (@{$status{blocks_array}}) {
+ $output .= q(<span>Blocking fix for ).
+ join(q(, ),
+ map {bug_links(bug=>$_->{bug_num}).q(: ).html_escape($_->{subject})}
+ @{$status{blocks_array}}).q(;</span> )
+ }
+ $output;
+}{ my $output = '';
+ my ($days_last,$eng_last) = secs_to_english(time - $status{log_modified});
+ my ($days,$eng) = secs_to_english(time - $status{date});
+
+ if ($days >= 7) {
+ my $font = "";
+ my $efont = "";
+ $font = "em" if ($days > 30);
+ $font = "strong" if ($days > 60);
+ $efont = "</$font>" if ($font);
+ $font = "<$font>" if ($font);
+
+ $output .= "<span>${font}Filed $eng ago$efont;</span>\n";
+ }
+ if ($days_last > 7) {
+ my $font = "";
+ my $efont = "";
+ $font = "em" if ($days_last > 30);
+ $font = "strong" if ($days_last > 60);
+ $efont = "</$font>" if ($font);
+ $font = "<$font>" if ($font);
+
+ $output .= "<span>${font}Modified $eng_last ago$efont;</span>\n";
+ }
+ $output;
+ }{ my $output = '';
+ if (exists $status{archived} and $status{archived}) {
+ $output .= q(<span>Bug is archived. No further changes may be made.<span> )
+ }
+ $output}</div>
+</div>
--- /dev/null
+<ADDRESS>{$config{maintainer}} <<A HREF="mailto:{$config{maintainer_email}}">{$config{maintainer_email}}</A>>.
+Last modified:
+<!--timestamp-->
+{$last_modified||strftime('%c',gmtime)}
+<!--timestamp-->
+<P>
+<A HREF="http://{$config{web_domain}}/">{$config{project}} {$config{bug}} tracking system</A><BR>
+Copyright (C) 1999 Darren O. Benham,
+1997,2003 nCipher Corporation Ltd,
+1994-97 Ian Jackson.
+</ADDRESS>
--- /dev/null
+</title>
+<meta http-equiv="Content-Type" content="text/html;charset=utf-8">
+<link rel="stylesheet" href="{$config{web_host_bug_dir}}/css/bugs.css" type="text/css">
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
+<html><head>
+<title>
\ No newline at end of file
projects / debbugs.git / commitdiff