# Copyright (C) 2017 The Qt Company Ltd.
# SPDX-License-Identifier: LicenseRef-Qt-Commercial OR GPL-3.0-only WITH Qt-GPL-exception-1.0

package QtQA::App::TestRunner::Plugin::core;
use strict;
use warnings;

use Capture::Tiny qw( capture_merged );
use Carp;
use Data::Dumper;
use English qw( -no_match_vars );
use File::Temp;
use Readonly;

# not available on Windows; allow syntax check to work, at least
BEGIN {
    if ($OSNAME !~ m{win32}i) {
        require BSD::Resource; BSD::Resource->import( );
        require Tie::Sysctl;   Tie::Sysctl->import( );
    }
}

#use Smart::Comments;   # uncomment for debugging

Readonly my $LINUX => ($OSNAME =~ m{linux}i);
Readonly my $MAC   => ($OSNAME =~ m{darwin}i);

# Maximum permitted size of core files.
# On our Linux machines, asking for RLIM_INFINITY doesn't work
# for unknown reasons (even when the hard limit is infinity),
# so an arbitrary large number is used there.
Readonly my $CORE_LIMIT =>
    $LINUX ? 1024*1024*1024 : RLIM_INFINITY();

# Interface to /proc/sys values
tie my %SYSCTL, 'Tie::Sysctl' if $LINUX;

# get mtime of a file, or return -1 on error
sub mtime
{
    my ($file) = @_;
    return -1 if (! -e $file);

    my (@stat) = stat($file);

    return -1 if (! @stat);

    return $stat[9];
}

sub new
{
    my ($class, %args) = @_;

    if (!$LINUX && !$MAC) {
        croak "sorry, core plugin is currently not usable on $OSNAME";
    }

    return bless \%args, $class;
}

sub about_to_run
{
    my ($self) = @_;

    # Attempt to enable core dump for child processes
    if (!setrlimit( 'RLIMIT_CORE', $CORE_LIMIT, $CORE_LIMIT )) {
        $self->{ testrunner }->print_info(
            "enabling core dumps failed: setrlimit: $OS_ERROR\n"
           ."core dump may not be available if the test crashes :(\n"
        );
        return;
    }

    # Save time when the process begins, so we can check if the core dump
    # is new.
    $self->{ start_time } = time();

    return;
}

sub run_completed
{
    my ($self) = @_;

    my $testrunner = $self->{ testrunner };
    my $proc       = $testrunner->proc( );

    my $status = $proc->status( );

    my $signal     = ($status & 127);
    my $coredumped = ($status & 128);

    return if (!$signal);

    if ($signal && !$coredumped) {
        $testrunner->print_info(
            "It looks like the process exited due to a signal, but it didn't dump core :(\n"
           ."Sorry, a core dump will not be available.\n"
        );
        return;
    }

    $self->_find_and_handle_core_files( );

    return;
}

# Given the values of /proc/kernel/core_pattern and /proc/kernel/core_uses_pid,
# returns a pattern suitable for usage with glob() to find the relevant core files.
sub _core_pattern_to_glob_pattern
{
    my ($self, $core_pattern, $core_uses_pid) = @_;

    # There does not appear to be a practical way to feasibly determine who
    # dumped what, without having root permissions to control the core pattern.
    #
    # The core pattern may contain various strings, including the timestamp
    # at the time of the dump (not possible for us to determine), and the pid of
    # the process (possible for us to determine for the parent process, but not
    # for any subprocesses which may have crashed).
    #
    # Therefore, we use a simple hueristics-based approach which hopefully will
    # catch the majority of cases: we read the core pattern up to the first
    # variable portion, then we glob all files matching that pattern, and only
    # keep the ones with a timestamp more recent than when we started the process.
    #
    # For example, if the core pattern is like this:
    #
    #   /tmp/cores/core.%e.%p.%h.%t
    #
    # ...then we will find all files matching /tmp/cores/core.* who were created
    # after the process began.
    #
    # If the core pattern is piping to a program, then we guess that the program
    # will write out a core file "normally", for compatibility.  abrtd from Fedora
    # does this, for example.  We have no feasible way to guess exactly which core
    # pattern the program is going to use, so we just assume default of `core'.
    if ($core_pattern =~ m{ \A \| }xms) {
        $core_pattern = 'core';
    }

    # core_uses_pid is exactly equivalent to an extra .%p on the end of the pattern
    if ($core_uses_pid) {
        $core_pattern .= '.%p';
    }

    my $glob_pattern;

    my @characters = split //, $core_pattern;
    while (@characters) {
        my $c = shift @characters;

        if ($c ne '%') {
            $glob_pattern .= $c;
            next;
        }

        # We got a '%'.  Check the next character...
        $c = shift @characters;

        # silently drop single '%' at end of pattern ...
        last if (!defined($c));

        # retain '%%' -> '%' and continue parsing ...
        if ($c eq '%') {
            $glob_pattern .= $c;
            next;
        }

        # ...for anything else, it's something special.
        # Do not parse any further, we'll just glob the rest.
        $glob_pattern .= '*';
        last;
    }

    ### For core pattern  : $core_pattern
    ### Using glob pattern: $glob_pattern

    return $glob_pattern;
}

sub _core_pattern
{
    my ($self) = @_;

    if ($LINUX) {
        return $SYSCTL{ kernel }{ core_pattern };
    }
    elsif ($MAC) {
        # coredump path is always fixed on mac, see "Technical Note TN2124"
        return '/cores/core';
    }

    confess "internal error: unsupported OS $OSNAME";
}

sub _core_uses_pid
{
    my ($self) = @_;

    if ($LINUX) {
        return $SYSCTL{ kernel }{ core_uses_pid };
    }
    elsif ($MAC) {
        # coredump path always uses pid on MAC, see "Technical Note TN2124"
        return 1;
    }

    confess "internal error: unsupported OS $OSNAME";
}

# Attempts to find and return a list of all core files generated by the
# process.  Based on hueristics and may fail.
sub _find_core_files
{
    my ($self) = @_;

    my $glob_pattern = $self->_core_pattern_to_glob_pattern(
        $self->_core_pattern( ),
        $self->_core_uses_pid( ),
    );

    my @all = glob( $glob_pattern );

    return grep { mtime($_) >= $self->{ start_time } } @all;
}

sub _find_and_handle_core_files
{
    my ($self) = @_;

    my @files = $self->_find_core_files( );

    ### found core files: @files

    foreach my $file (@files) {
        $self->_handle_core_file( $file );
    }

    return;
}

sub _get_backtrace
{
    my ($self, $file) = @_;

    # Limit the backtrace lines to 100 in order to
    # prevent huge logfiles and slower builds
    my $MAX_BACKTRACE_FRAMES = '100';
    my $BACKTRACE_COMMANDS = "thread apply all bt $MAX_BACKTRACE_FRAMES";

    # Note, newer versions of gdb support an `--eval-command' option to
    # pass commands through the command line, but we want to support some
    # older gdb (e.g. on mac) which only have `-x'
    my $cmd_file = File::Temp->new( 'qtqa-testrunner-gdb.XXXXXX', TMPDIR => 1 );
    $cmd_file->printflush( $BACKTRACE_COMMANDS );

    my $command = ($self->{ testrunner }->command( ))[0];
    return capture_merged {
        print qq(gdb commands: $BACKTRACE_COMMANDS\n);
        my @cmd = (
            'gdb',
            $command,
            $file,
            '--batch',
            '-x',
            $cmd_file->filename( ),
        );

        my $status = system( @cmd );
        if ($status != 0) {
            print STDERR
                "while getting backtrace, gdb exited with status $status\n"
               ."gdb command: "
               .Data::Dumper->new( [ \@cmd ], [ 'cmd' ] )->Indent( 0 )->Dump( )
            ;
        }
    };
}

sub _handle_core_file
{
    my ($self, $file) = @_;

    my $testrunner = $self->{ testrunner };

    my $backtrace = $self->_get_backtrace( $file );
    if ($backtrace) {
        $testrunner->print_info(
            #
            # create nice chunk of text like:
            #
            #   ================== backtrace follows: ==================
            #   (the backtrace here)
            #   ========================================================
            #
            ('=' x 30). ' backtrace follows: ' . ('=' x 30) . "\n"
           ."$backtrace\n"
           .('=' x 80)."\n"
        );
    }

    if (! unlink( $file )) {
        $testrunner->print_info( "warning: could not remove core dump $file: $OS_ERROR\n" );
    }

    return;
}

=head1 NAME

QtQA::App::TestRunner::Plugin::core - process core files from crashing tests

=head1 SYNOPSIS

  # without this plugin:
  $ testrunner --capture-logs $HOME/test-logs -- tst_crashy
  # $HOME/test-logs/tst_crashy-00.txt says "process exited with signal 11 ..."

  # with this plugin:
  $ testrunner --plugin core --capture-logs $HOME/test-logs -- tst_crashy
  # $HOME/test-logs/tst_crashy-00.txt says "process exited with signal 11 ..."
  # and also contains a full backtrace of all threads

=head1 DESCRIPTION

This plugin will perform the following:

=over

=item *

Prior to the running of the command, testrunner will attempt to enable core dumps
via setrlimit().  This may fail depending on system policy, which will cause a
warning.

=item *

After the command completes, its status is checked.  If it appears to have dumped
core, testrunner will attempt to find the core file (and also the core files of any
subprocesses).

=item *

For each core file, gdb is launched and asked to give a full backtrace of each
thread.  This will be printed to STDERR and/or appended to the test log.

=back

=head1 CAVEATS

Only works on Linux and Mac.

On Mac, core dumps can be very slow to create.  In practice, times of up to
20 minutes to create a single core dump have been observed.  This may make the
usage of this plugin prohibitively slow on Mac.  Consider using the
Mac-specific "crashreporter" plugin instead.

It is not possible for a normal user to control the location where core files
are generated.  Also, it is possible for the system to be configured in such
a way that core files are generated in an unpredictable or inaccessible path.
Therefore, the detection of core files is based on heuristics, which should
cover the majority of use-cases but may fail for more exotic setups.
In particular, this will not work at all on systems where the core_pattern
is set up to pipe to a program.

Currently, the core files are deleted after extracting a backtrace.
There is no mechanism to permanently capture the core files - the size to
value ratio does not seem to warrant it at this time.

=cut

1;