181 lines
4 KiB
Perl
181 lines
4 KiB
Perl
# Licensed to the Apache Software Foundation (ASF) under one or more
|
|
# contributor license agreements. See the NOTICE file distributed with
|
|
# this work for additional information regarding copyright ownership.
|
|
# The ASF licenses this file to You under the Apache License, Version 2.0
|
|
# (the "License"); you may not use this file except in compliance with
|
|
# the License. You may obtain a copy of the License at
|
|
#
|
|
# http://www.apache.org/licenses/LICENSE-2.0
|
|
#
|
|
# Unless required by applicable law or agreed to in writing, software
|
|
# distributed under the License is distributed on an "AS IS" BASIS,
|
|
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
|
# See the License for the specific language governing permissions and
|
|
# limitations under the License.
|
|
#
|
|
package Apache::TestReport;
|
|
|
|
use strict;
|
|
use warnings FATAL => 'all';
|
|
|
|
use Apache::Test ();
|
|
use Apache::TestConfig ();
|
|
|
|
use File::Spec::Functions qw(catfile);
|
|
use File::Find;
|
|
|
|
sub new {
|
|
my $class = shift;
|
|
bless { @_ }, $class;
|
|
}
|
|
|
|
# generate t/REPORT script (or a different filename) which will drive
|
|
# Apache::TestReport
|
|
sub generate_script {
|
|
my ($class, $file) = @_;
|
|
|
|
$file ||= catfile 't', 'REPORT';
|
|
|
|
my $content = join "\n",
|
|
"BEGIN { eval { require blib && blib->import; } }",
|
|
Apache::TestConfig->perlscript_header,
|
|
"use $class;",
|
|
"$class->new(\@ARGV)->run;";
|
|
|
|
Apache::Test::basic_config()->write_perlscript($file, $content);
|
|
}
|
|
|
|
sub replace {
|
|
my($self, $template) = @_;
|
|
|
|
$template =~ s{\@(\w+)\@} {
|
|
my $method = lc $1;
|
|
eval { $self->$method() } || $self->{$1} || '';
|
|
}eg;
|
|
|
|
$template;
|
|
}
|
|
|
|
sub run {
|
|
my $self = shift;
|
|
|
|
print $self->replace($self->template);
|
|
}
|
|
|
|
sub config { Apache::TestConfig::as_string() }
|
|
|
|
sub report_to { 'test-dev@httpd.apache.org' }
|
|
|
|
sub postit_note {
|
|
my $self = shift;
|
|
|
|
my($to, $where) = split '@', $self->report_to;
|
|
|
|
return <<EOF;
|
|
Note: Complete the rest of the details and post this bug report to
|
|
$to <at> $where. To subscribe to the list send an empty
|
|
email to $to-subscribe\@$where.
|
|
EOF
|
|
}
|
|
|
|
sub executable { $0 }
|
|
|
|
my $core_dump;
|
|
sub core_dump {
|
|
my $self = shift;
|
|
|
|
$core_dump = "";
|
|
|
|
if (eval { require Devel::GDB }) {
|
|
find(\&dump_core_file, 't')
|
|
}
|
|
|
|
$core_dump || ' [CORE TRACE COMES HERE]';
|
|
}
|
|
|
|
sub dump_core_file {
|
|
return unless /^core(\.\d+)?$/;
|
|
|
|
my $core = $_;
|
|
my $gdb = new Devel::GDB ();
|
|
my $test_config = Apache::TestConfig->new({thaw=>1});
|
|
my $httpd = $test_config->{vars}->{httpd};
|
|
|
|
return unless defined $httpd;
|
|
|
|
$core_dump .= join '',
|
|
$gdb->get("file $httpd"),
|
|
$gdb->get('sharedlibrary'),
|
|
$gdb->get("core $core"),
|
|
$gdb->get('info threads'),
|
|
$gdb->get('thread apply all bt');
|
|
}
|
|
|
|
sub date { scalar gmtime() . " GMT" }
|
|
|
|
sub template {
|
|
<<'EOI'
|
|
-------------8<---------- Start Bug Report ------------8<----------
|
|
1. Problem Description:
|
|
|
|
[DESCRIBE THE PROBLEM HERE]
|
|
|
|
2. Used Components and their Configuration:
|
|
|
|
@CONFIG@
|
|
|
|
3. This is the core dump trace: (if you get a core dump):
|
|
|
|
@CORE_DUMP@
|
|
|
|
This report was generated by @EXECUTABLE@ on @DATE@.
|
|
|
|
-------------8<---------- End Bug Report --------------8<----------
|
|
|
|
@POSTIT_NOTE@
|
|
|
|
EOI
|
|
|
|
}
|
|
|
|
1;
|
|
__END__
|
|
|
|
=head1 NAME
|
|
|
|
Apache::TestReport - A parent class for generating bug/success reports
|
|
|
|
=head1 Synopsis
|
|
|
|
use Apache::TestReport;
|
|
Apache::TestReport->new(@ARGV)->run;
|
|
|
|
=head1 Description
|
|
|
|
This class is used to generate a bug or a success report, providing
|
|
information about the system the code was running on.
|
|
|
|
=head1 Overridable Methods
|
|
|
|
=head2 config
|
|
|
|
return the information about user's system
|
|
|
|
=head2 report_to
|
|
|
|
return a string containing the email address the report should be sent
|
|
to
|
|
|
|
=head2 postit_note
|
|
|
|
return a string to close the report with, e.g.:
|
|
|
|
my($to, $where) = split '@', $self->report_to;
|
|
return <<EOF;
|
|
Note: Complete the rest of the details and post this bug report to
|
|
$to <at> $where. To subscribe to the list send an empty
|
|
email to $to-subscribe\@$where.
|
|
|
|
|
|
=cut
|
|
|