xref: /dports/devel/p5-Test2-Harness/Test2-Harness-1.000082/lib/Test2/Harness/Runner/Job.pm

package Test2::Harness::Runner::Job;
use strict;
use warnings;

our $VERSION = '1.000082';

use Carp qw/confess croak/;
use Config qw/%Config/;
use Scalar::Util qw/weaken blessed/;
use Test2::Util qw/CAN_REALLY_FORK/;
use Time::HiRes qw/time/;

use File::Spec();
use File::Temp();

use Test2::Harness::Util qw/fqmod clean_path write_file_atomic write_file mod2file open_file parse_exit process_includes chmod_tmp/;
use Test2::Harness::IPC;

use parent 'Test2::Harness::IPC::Process';
use Test2::Harness::Util::HashBase(
    qw{ <task <runner <run <settings }, # required
    qw{
        <fork_callback
        <last_output_size
        +output_changed

        +verbose

        +via

        +run_dir +job_dir +tmp_dir +event_dir

        +ch_dir +unsafe_inc

        +use_fork +use_w_switch

        +includes +runner_includes
        +switches
        +use_stream
        +cli_includes
        +cli_options

        +smoke
        +retry +retry_isolated +is_try

        +args +file +run_file

        +out_file +err_file +in_file +bail_file

        +load +load_import

        +event_uuids +mem_usage +io_events

        +env_vars

        +event_timeout +post_exit_timeout +use_timeout

        +switches_from_env

        +et_file +pet_file
    }
);

sub category { 'job' }

sub init {
    my $self = shift;

    croak "'runner' is a required attribute"   unless $self->{+RUNNER};
    croak "'run' is a required attribute"      unless $self->{+RUN};
    croak "'settings' is a required attribute" unless $self->{+SETTINGS};

    delete $self->{+JOB_DIR};

    # Avoid a ref cycle
    #weaken($self->{+RUNNER});

    my $task = $self->{+TASK} or croak "'task' is a required attribute";

    delete $self->{+LAST_OUTPUT_SIZE};

    confess "Task does not have a job ID" unless $task->{job_id};
    confess "Task does not have a file"   unless $task->{file};
}

sub job_id { $_[0]->{+TASK}->{job_id} }

sub prepare_dir {
    my $self = shift;

    $self->job_dir();
    $self->tmp_dir();
    $self->event_dir();
}

sub via {
    my $self = shift;

    return undef if $self->{+SETTINGS}->debug->dummy;

    return $self->{+VIA} if exists $self->{+VIA};

    my $task = $self->{+TASK};
    return $self->{+VIA} = $task->{via} if $task->{via};

    return $self->{+VIA} = $self->{+FORK_CALLBACK} if $self->{+FORK_CALLBACK} && $self->use_fork;

    return $self->{+VIA} = undef;
}

sub spawn_params {
    my $self = shift;

    my $task = $self->{+TASK};

    my $command;
    if ($task->{binary} || $task->{non_perl}) {
        my $file = $self->ch_dir ? $self->file : $self->rel_file;
        $command = [clean_path($file), $self->args];
    }
    else {
        $command = [
            $^X,
            $self->cli_includes,
            $self->{+SETTINGS}->runner->nytprof ? ('-d:NYTProf') : (),
            $self->switches,
            $self->cli_options,

            $self->{+SETTINGS}->debug->dummy ? ('-e', 'print "1..0 # SKIP dummy mode"') : (sub { $self->run_file }),

            $self->args,
        ];
    }

    my $out_fh = open_file($self->out_file, '>');
    my $err_fh = open_file($self->err_file, '>');
    my $in_fh  = open_file($self->in_file,  '<');

    return {
        command => $command,
        stdin   => $in_fh,
        stdout  => $out_fh,
        stderr  => $err_fh,
        chdir   => $self->ch_dir(),
        env     => $self->env_vars(),
    };
}

sub switches_from_env {
    my $self = shift;

    return @{$self->{+SWITCHES_FROM_ENV}} if $self->{+SWITCHES_FROM_ENV};

    return @{$self->{+SWITCHES_FROM_ENV} = []} unless $ENV{HARNESS_PERL_SWITCHES};

    return @{$self->{+SWITCHES_FROM_ENV} = [split /\s+/, $ENV{HARNESS_PERL_SWITCHES}]};
}

my %JSON_SKIP = (
    SETTINGS()         => 1,
    TASK()             => 1,
    RUNNER()           => 1,
    RUN()              => 1,
    CLI_INCLUDES()     => 1,
    CLI_OPTIONS()      => 1,
    ERR_FILE()         => 1,
    ET_FILE()          => 1,
    EVENT_DIR()        => 1,
    EXIT()             => 1,
    EXIT_TIME()        => 1,
    IN_FILE()          => 1,
    JOB_DIR()          => 1,
    LAST_OUTPUT_SIZE() => 1,
    OUT_FILE()         => 1,
    BAIL_FILE()        => 1,
    OUTPUT_CHANGED()   => 1,
    PET_FILE()         => 1,
    RUN_DIR()          => 1,
    TMP_DIR()          => 1,
);

sub TO_JSON {
    my $self = shift;

    my $out = { %{$self->{+TASK}} };

    for my $attr (Test2::Harness::Util::HashBase::attr_list(blessed($self))) {
        next if $JSON_SKIP{$attr};
        $self->$attr unless defined $self->{$attr};
        $out->{$attr} = $self->{$attr};
    }

    delete $out->{+FORK_CALLBACK};
    delete $out->{+VIA} if ref($out->{+VIA}) eq 'CODE';

    $out->{job_name} //= $out->{job_id};
    $out->{abs_file} = clean_path($self->file);

    return $out;
}

sub run_file  {
    my $self = shift;
    return $self->{+RUN_FILE} //= $self->rel_file;
}

sub rel_file  { File::Spec->abs2rel($_[0]->file) }
sub file      { $_[0]->{+FILE}      //= clean_path($_[0]->{+TASK}->{file}, 0) }
sub err_file  { $_[0]->{+ERR_FILE}  //= clean_path(File::Spec->catfile($_[0]->job_dir, 'stderr')) }
sub out_file  { $_[0]->{+OUT_FILE}  //= clean_path(File::Spec->catfile($_[0]->job_dir, 'stdout')) }
sub bail_file { $_[0]->{+BAIL_FILE} //= clean_path(File::Spec->catfile($_[0]->event_dir, 'bail')) }
sub et_file   { $_[0]->{+ET_FILE}   //= clean_path(File::Spec->catfile($_[0]->job_dir, 'event_timeout')) }
sub pet_file  { $_[0]->{+PET_FILE}  //= clean_path(File::Spec->catfile($_[0]->job_dir, 'post_exit_timeout')) }
sub run_dir   { $_[0]->{+RUN_DIR}   //= clean_path(File::Spec->catdir($_[0]->{+RUNNER}->dir, $_[0]->{+RUN}->run_id)) }

sub bailed_out {
    my $self = shift;

    if(-f $self->bail_file) {
        my $fh = open_file($self->bail_file, '<');
        my $reason = <$fh> || 1;
        return $reason;
    }

    my $fh = open_file($self->out_file, '<');
    while (my $line = <$fh>) {
        next unless $line =~ m/^Bail out!\s*(.*)$/;
        return $1 || 1;
    }

    return "";
}

sub output_size {
    my $self = shift;

    my $size = 0;

    $size += -s $self->err_file || 0;
    $size += -s $self->out_file || 0;

    return $self->{+LAST_OUTPUT_SIZE} = $size;
}

sub output_changed {
    my $self = shift;

    my $last = $self->{+LAST_OUTPUT_SIZE};
    my $size = $self->output_size();

    # Output changed, update time
    return $self->{+OUTPUT_CHANGED} = time() if $last && $size != $last;

    # Return the last recorded time, if there is no previously recorded time then the record starts now
    return $self->{+OUTPUT_CHANGED} //= time();
}

sub verbose { $_[0]->{+VERBOSE} //= $_[0]->{+TASK}->{verbose} // 0 }
sub is_try  { $_[0]->{+IS_TRY}  //= $_[0]->{+TASK}->{is_try}  // 0 }
sub ch_dir  { $_[0]->{+CH_DIR}  //= $_[0]->{+TASK}->{ch_dir}  // '' }
sub unsafe_inc  { $_[0]->{+UNSAFE_INC}  //= $_[0]->{+RUNNER}->unsafe_inc }
sub event_uuids { $_[0]->{+EVENT_UUIDS} //= $_[0]->run->event_uuids }
sub mem_usage   { $_[0]->{+MEM_USAGE}   //= $_[0]->run->mem_usage }

sub io_events { $_[0]->{+IO_EVENTS} //= $_[0]->_fallback(io_events => 1, qw/task run/) }

sub smoke             { $_[0]->{+SMOKE}             //= $_[0]->_fallback(smoke             => 0,     qw/task/) }
sub retry_isolated    { $_[0]->{+RETRY_ISOLATED}    //= $_[0]->_fallback(retry_isolated    => 0,     qw/task run/) }
sub use_stream        { $_[0]->{+USE_STREAM}        //= $_[0]->_fallback(use_stream        => 1,     qw/task run/) }
sub use_timeout       { $_[0]->{+USE_TIMEOUT}       //= $_[0]->_fallback(use_timeout       => 1,     qw/task/) }
sub retry             { $_[0]->{+RETRY}             //= $_[0]->_fallback(retry             => undef, qw/task run/) }
sub event_timeout     { $_[0]->{+EVENT_TIMEOUT}     //= $_[0]->_fallback(event_timeout     => undef, qw/task runner/) }
sub post_exit_timeout { $_[0]->{+POST_EXIT_TIMEOUT} //= $_[0]->_fallback(post_exit_timeout => undef, qw/task runner/) }


sub args { @{$_[0]->{+ARGS} //= $_[0]->_merge_sources(test_args => qw/task run/)} }
sub load { @{$_[0]->{+LOAD} //= [@{$_[0]->run->load // []}]} }

sub cli_includes {
    my $self = shift;

    # '.' is handled via the PERL_USE_UNSAFE_INC env var set later
    $self->{+CLI_INCLUDES} //= [map { "-I$_" } grep { $_ ne '.' } $self->includes];

    return @{$self->{+CLI_INCLUDES}};
}

sub runner_includes { @{$_[0]->{+RUNNER_INCLUDES} //= [$_[0]->{+RUNNER}->all_libs]} }

sub _merge_sources {
    my $self = shift;
    my ($name, @from) = @_;

    my @vals;
    for my $from (@from) {
        my $source = $self->$from;
        my $val = blessed($source) ? $source->$name : $source->{$name};
        next unless defined $val;
        next unless @$val;
        push @vals => @$val;
    }

    return \@vals;
}

sub _fallback {
    my $self = shift;
    my ($name, $default, @from) = @_;

    my @vals;
    for my $from (@from) {
        my $source = $self->$from;
        my $val = blessed($source) ? $source->$name : $source->{$name};
        push @vals => $val if defined $val;
    }

    return $default unless @vals;

    # If the default is a ref we will just return the first value we found, truthiness check is useless
    return shift @vals if ref $default || !defined($default) || $default !~ m/^(0|1)$/;

    # If the default is true, then we only return true if none of the vals are false
    return !grep { !$_ } @vals if $default;

    # If the default is false, then we return true if any of the valse are true
    return grep { $_ } @vals;
}

sub job_dir {
    my $self = shift;
    return $self->{+JOB_DIR} if $self->{+JOB_DIR};

    my $job_dir = File::Spec->catdir($self->run_dir, $self->{+TASK}->{job_id} . '+' . $self->is_try);
    mkdir($job_dir) or die "$$ $0 Could not create job directory '$job_dir': $!";
    chmod_tmp($job_dir);
    $self->{+JOB_DIR} = $job_dir;
}

sub tmp_dir {
    my $self = shift;

    return $self->{+TMP_DIR} if $self->{+TMP_DIR};

    my $tmp_dir = File::Temp::tempdir("XXXXXX", DIR => $self->runner->tmp_dir);
    chmod_tmp($tmp_dir);

    $self->{+TMP_DIR} = clean_path($tmp_dir);
}

sub make_event_dir { $_[0]->event_dir }
sub event_dir {
    my $self = shift;
    return $self->{+EVENT_DIR} if $self->{+EVENT_DIR};

    my $events_dir = File::Spec->catdir($self->job_dir, 'events');
    unless (-d $events_dir) {
        mkdir($events_dir) or die "$$ $0 Could not create events directory '$events_dir': $!";
    }
    $self->{+EVENT_DIR} = $events_dir;
}

sub in_file {
    my $self = shift;
    return $self->{+IN_FILE} if $self->{+IN_FILE};

    my $task = $self->{+TASK};

    unless ($task->{input}) {
        my $from_run = $self->run->input_file;
        return $self->{+IN_FILE} = $from_run if $from_run;
    }

    my $stdin = File::Spec->catfile($self->job_dir, 'stdin');

    my $content = $task->{input} // $self->run->input // '';
    write_file($stdin, $content);

    return $self->{+IN_FILE} = $stdin;
}

sub use_fork {
    my $self = shift;

    return $self->{+USE_FORK} if defined $self->{+USE_FORK};

    my $task = $self->{+TASK};

    return $self->{+USE_FORK} = 0 unless CAN_REALLY_FORK;
    return $self->{+USE_FORK} = 0 if $task->{binary};
    return $self->{+USE_FORK} = 0 if $task->{non_perl};
    return $self->{+USE_FORK} = 0 if defined($task->{use_fork}) && !$task->{use_fork};
    return $self->{+USE_FORK} = 0 if defined($task->{use_preload}) && !$task->{use_preload};

    # -w switch is ok, otherwise it is a no-go
    return $self->{+USE_FORK} = 0 if grep { !m/\s*-w\s*/ } $self->switches;

    my $runner = $self->{+RUNNER};
    return $self->{+USE_FORK} = 0 unless $runner->use_fork;

    return $self->{+USE_FORK} = 1;
}

sub includes {
    my $self = shift;

    return @{$self->{+INCLUDES}} if $self->{+INCLUDES};

    $self->{+INCLUDES} = [
        process_includes(
            list            => [$self->runner_includes, @{$self->{+SETTINGS}->harness->orig_inc}],
            include_dot     => $self->unsafe_inc,
            include_current => 1,
            clean           => 1,
            $self->ch_dir ? (ch_dir => $self->ch_dir) : (),
        )
    ];

    return @{$self->{+INCLUDES}};
}

sub cli_options {
    my $self = shift;

    my $event_dir = $self->event_dir;
    my $job_id = $self->job_id;

    return (
        $self->use_stream  ? ("-MTest2::Formatter::Stream=dir,$event_dir,job_id,$job_id") : (),
        $self->event_uuids ? ('-MTest2::Plugin::UUID')                     : (),
        $self->mem_usage   ? ('-MTest2::Plugin::MemUsage')                 : (),
        $self->io_events   ? ('-MTest2::Plugin::IOEvents')                 : (),
        (map { @{$_->[1]} ? "-M$_->[0]=" . join(',' => @{$_->[1]}) : "-M$_->[0]" } $self->load_import),
        (map { "-m$_" } $self->load),
    );
}

sub switches {
    my $self = shift;

    return @{$self->{+SWITCHES}} if $self->{+SWITCHES};

    my @switches;

    my %seen;
    for my $s (@{$self->{+TASK}->{switches} // []}) {
        $seen{$s}++;
        $self->{+USE_W_SWITCH} = 1 if $s =~ m/\s*-w\s*/;
        push @switches => $s;
    }

    my %seen2;
    for my $s (@{$self->{+RUNNER}->switches // []}) {
        next if $seen{$s};
        $seen2{$s}++;
        $self->{+USE_W_SWITCH} = 1 if $s =~ m/\s*-w\s*/;
        push @switches => $s;
    }

    for my $s ($self->switches_from_env) {
        next if $seen{$s};
        next if $seen2{$s};
        $self->{+USE_W_SWITCH} = 1 if $s =~ m/\s*-w\s*/;
        push @switches => $s;
    }

    return @{$self->{+SWITCHES} = \@switches};
}

sub prof_file {
    my $self = shift;
    my $file =$self->rel_file;

    $file =~ s{/}{-}g;
    $file =~ s{\.[^\.]+$}{.nytprof}g;

    return $file;
}

sub env_vars {
    my $self = shift;

    return $self->{+ENV_VARS} if $self->{+ENV_VARS};

    my $from_run = $self->run->env_vars;
    my $from_task = $self->{+TASK}->{env_vars};

    my @p5l = ($from_task->{PERL5LIB}, $from_run->{PERL5LIB});
    push @p5l => $self->includes if $self->{+TASK}->{binary} || $self->{+TASK}->{non_perl};
    push @p5l => $ENV{PERL5LIB} if $ENV{PERL5LIB};
    my $p5l = join $Config{path_sep} => grep { defined $_ && $_ ne '.' } @p5l;

    my $verbose = $self->verbose;

    return $self->{+ENV_VARS} = {
        $from_run  ? (%$from_run)  : (),
        $from_task ? (%$from_task) : (),

        $self->use_stream ? (T2_FORMATTER => 'Stream', T2_STREAM_DIR => $self->event_dir, T2_STREAM_JOB_ID => $self->job_id) : (),

        $self->{+SETTINGS}->runner->nytprof ? (NYTPROF => "addpid=1:start=begin") : (),

        PERL5LIB            => $p5l,
        PERL_USE_UNSAFE_INC => $self->unsafe_inc,
        TEST2_JOB_DIR       => $self->job_dir,
        TEST2_RUN_DIR       => $self->run_dir,
        TMPDIR              => $self->tmp_dir,
        TEMPDIR             => $self->tmp_dir,
        SYSTEM_TMPDIR       => $self->{+SETTINGS}->harness->orig_tmp,
        SYSTEM_TMPDIR_PERMS => $self->{+SETTINGS}->harness->orig_tmp_perms,

        HARNESS_IS_VERBOSE    => $verbose,
        T2_HARNESS_IS_VERBOSE => $verbose,

        HARNESS_ACTIVE       => 1,
        TEST2_HARNESS_ACTIVE => 1,

        T2_HARNESS_JOB_FILE     => $self->rel_file,
        T2_HARNESS_JOB_NAME     => $self->{+TASK}->{job_name},
        T2_HARNESS_JOB_IS_TRY   => $self->{+IS_TRY}           // 0,
        T2_HARNESS_JOB_DURATION => $self->{+TASK}->{duration} // '',
    };
}

sub load_import {
    my $self = shift;

    return @{$self->{+LOAD_IMPORT}} if $self->{+LOAD_IMPORT};

    my $from_run = $self->run->load_import;

    my @out;
    for my $mod (@{$from_run->{'@'} // []}) {
        push @out => [$mod, $from_run->{$mod} // []];
    }

    return @{$self->{+LOAD_IMPORT} = \@out};
}

sub use_w_switch {
    my $self = shift;
    return $self->{+USE_W_SWITCH} if defined $self->{+USE_W_SWITCH};
    $self->switches;
    return $self->{+USE_W_SWITCH};
}

sub set_exit {
    my $self = shift;
    my ($runner, $exit, $time, @args) = @_;

    $self->SUPER::set_exit(@_);

    my $file = File::Spec->catfile($self->job_dir, 'exit');

    my $e = parse_exit($exit);

    write_file_atomic($file, join(" " => $exit, $e->{err}, $e->{sig}, $e->{dmp}, $time, @args));
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::Harness::Runner::Job - Representation of a test job.

=head1 DESCRIPTION

This module takes all the data from a test file queue item, a run, and runner
settings, and mashes them together to figure out what is actually needed to run
a job.

=head1 METHODS

Note, this object subclasses L<Test2::Harness::IPC::Process>.

=over 4

=item $arrayref = $job->args

Get the arguments for the test either formt he queue item, or from the run.

=item $path = $job->bail_file

Path to the events-file used in case of a bail-out

=item $bool = $job->bailed_out

True if the test job bailed out.

=item $cat $job->category

Process category, always 'job' unless overriden in a subclass.

=item $path = $job->ch_dir

If this job first requires a change in directory before running, this will
return the path.

=item @list = $job->cli_includes

List of includes for a command line launch of this job.

=item @list = $job->cli_options

List of options for a command line launch of this job.

=item $hashref = $job->env_vars

Get environment variables to set when launching this job.

=item $path = $job->out_file

File to which all STDOUT for the job will be written.

=item $path = $job->err_file

File to which all STDERR for the job will be written.

=item $path = $job->et_file

File to which event timeout notifications will be written.

=item $path = $job->pet_file

File to which post exit timeout events will be written.

=item $path = $job->event_dir

Directory to which L<Test2::Formatter::Stream> events will be written.

=item $time = $job->event_timeout

Event timeout specification, if any, first from test queue item, then from
runner.

=item $time = $job->post_exit_timeout

Post exit timeout specification, if any, first from test queue item, then from
runner.

=item $bool = $job->event_uuids

Use L<Test2::Plugin::UUID> inside the test.

=item $path = $job->file

Test file the job will be running.

=item $coderef = $job->fork_callback

If the job is to be launched via fork, use this callback.

=item $path = $job->in_file

File containing STDIN to be provided to the test.

=item @list = $job->includes

Paths to add to @INC for the test.

=item $bool = $job->io_events

True if L<Test2::Plugin::IOEvents> should be used.

=item $int = $job->is_try

This starts at 0 and will be incremented for every retry of the job.

=item $path = $job->job_dir

Temporary directory housing all files related to this job when it runs.

=item $uuid = $job->job_id

UUID for this job.

=item @list = $job->load

Modules to load when starting this job.

=item @list = $job->load_import

Modules to load and import when starting this job.

=item $bool = $job->mem_usage

True if the L<Test2::Plugin::MemUsage> plugin should be used.

=item $path = $job->run_file

Usually the same as rel_file, but you can specify an alternative file to
actually run.

=item $path = $job->rel_file

Relative path to the file.

=item $int = $job->retry

How many times the test should be retried if it fails.

=item $bool = $job->retry_isolated

True if the test should be retried in isolation if it fails.

=item $run = $job->run

The L<Test2::Harness::Runner::Run> instance.

=item $path = $job->run_dir

Path to the temporary directory housing all the data about the run.

=item $runner = $job->runner

The L<Test2::Harness::Runner> instance.

=item @list = $job->runner_includes

Search path includes provided directly by the runner.

=item $settings = $job->settings

The L<Test2::Harness::Settings> instance.

=item $bool = $job->smoke

True if the test is a priority smoke test.

=item $hashref = $job->spawn_params

Parameters for C<run_cmd()> in L<Test2::Harness::Util::IPC> when launching this
job.

=item @list = $job->switches

Command line switches for perl when running this test.

=item $hashref = $job->task

Task data from the queue.

=item $path = $job->tmp_dir

Temp dir created specifically for this job.

=item $bool = $job->unsafe_inc

True if '.' should be added to C<@INC>.

=item $bool = $job->use_fork

True if this job should be launched via fork.

=item $bool = $job->use_stream

True if this job should use L<Test2::Formatter::Stream>.

=item $bool = $job->use_timeout

True if this job should timeout due to lack of activity.

=item $bool = $job->use_w_switch

True if the C<-w> switch should be used for this test.

=back

=head1 SOURCE

The source code repository for Test2-Harness can be found at
F<http://github.com/Test-More/Test2-Harness/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>.

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

See F<http://dev.perl.org/licenses/>

=cut