File Coverage

blib/lib/Test2/IPC/Driver/Files.pm

Criterion	Covered	Total	%
statement	168	168	100.0
branch	75	92	81.5
condition	11	15	73.3
subroutine	24	24	100.0
pod	7	11	63.6
total	285	310	91.9

package Test2::IPC::Driver::Files;
use strict;
use warnings;

our $VERSION = '0.000043';
$VERSION = eval $VERSION;    ## no critic (BuiltinFunctions::ProhibitStringyEval)

use base 'Test2::IPC::Driver';

use Test2::Util::HashBase qw{tempdir event_id tid pid globals};

use Scalar::Util qw/blessed/;
use File::Temp();
use Storable();
use File::Spec();

use Test2::Util qw/try get_tid pkg_to_file/;
use Test2::API qw/test2_ipc_set_pending/;

sub use_shm { 1 }
sub shm_size() { 64 }

sub is_viable { 1 }

sub init {
    my $self = shift;

    my $tmpdir = File::Temp::tempdir(
        $ENV{T2_TEMPDIR_TEMPLATE} || "test2-$$-XXXXXX",
        CLEANUP => 0,
        TMPDIR => 1,
    );

    $self->abort_trace("Could not get a temp dir") unless $tmpdir;

    $self->{+TEMPDIR} = File::Spec->canonpath($tmpdir);

    print STDERR "\nIPC Temp Dir: $tmpdir\n\n"
        if $ENV{T2_KEEP_TEMPDIR};

    $self->{+EVENT_ID} = 1;

    $self->{+TID} = get_tid();
    $self->{+PID} = $$;

    $self->{+GLOBALS} = {};

    return $self;
}

sub hub_file {
    my $self = shift;
    my ($hid) = @_;
    my $tdir = $self->{+TEMPDIR};
    return File::Spec->canonpath("$tdir/HUB-$hid");
}

sub event_file {
    my $self = shift;
    my ($hid, $e) = @_;

    my $tempdir = $self->{+TEMPDIR};
    my $type = blessed($e) or $self->abort("'$e' is not a blessed object!");

    $self->abort("'$e' is not an event object!")
        unless $type->isa('Test2::Event');

    my @type = split '::', $type;
    my $name = join('-', $hid, $$, get_tid(), $self->{+EVENT_ID}++, @type);

    return File::Spec->canonpath("$tempdir/$name");
}

sub add_hub {
    my $self = shift;
    my ($hid) = @_;

    my $hfile = $self->hub_file($hid);

    $self->abort_trace("File for hub '$hid' already exists")
        if -e $hfile;

    open(my $fh, '>', $hfile) or $self->abort_trace("Could not create hub file '$hid': $!");
    print $fh "$$\n" . get_tid() . "\n";
    close($fh);
}

sub drop_hub {
    my $self = shift;
    my ($hid) = @_;

    my $tdir = $self->{+TEMPDIR};
    my $hfile = $self->hub_file($hid);

    $self->abort_trace("File for hub '$hid' does not exist")
        unless -e $hfile;

    open(my $fh, '<', $hfile) or $self->abort_trace("Could not open hub file '$hid': $!");
    my ($pid, $tid) = <$fh>;
    close($fh);

    $self->abort_trace("A hub file can only be closed by the process that started it\nExpected $pid, got $$")
        unless $pid == $$;

    $self->abort_trace("A hub file can only be closed by the thread that started it\nExpected $tid, got " . get_tid())
        unless get_tid() == $tid;

    if ($ENV{T2_KEEP_TEMPDIR}) {
        rename($hfile, File::Spec->canonpath("$hfile.complete")) or $self->abort_trace("Could not rename file '$hfile' -> '$hfile.complete'");
    }
    else {
        unlink($hfile) or $self->abort_trace("Could not remove file for hub '$hid'");
    }

    opendir(my $dh, $tdir) or $self->abort_trace("Could not open temp dir!");
    for my $file (readdir($dh)) {
        next if $file =~ m{\.complete$};
        next unless $file =~ m{^$hid};
        $self->abort_trace("Not all files from hub '$hid' have been collected!");
    }
    closedir($dh);
}

sub send {
    my $self = shift;
    my ($hid, $e, $global) = @_;

    my $tempdir = $self->{+TEMPDIR};
    my $hfile = $self->hub_file($hid);
    my $dest = $global ? 'GLOBAL' : $hid;

    $self->abort(<<"    EOT") unless $global || -f $hfile;
hub '$hid' is not available, failed to send event!

There was an attempt to send an event to a hub in a parent process or thread,
but that hub appears to be gone. This can happen if you fork, or start a new
thread from inside subtest, and the parent finishes the subtest before the
child returns.

This can also happen if the parent process is done testing before the child
finishes. Test2 normally waits automatically in the root process, but will not
do so if Test::Builder is loaded for legacy reasons.
    EOT

    my $file = $self->event_file($dest, $e);
    my $ready = File::Spec->canonpath("$file.ready");

    if ($global) {
        my $name = $ready;
        $name =~ s{^.*(GLOBAL)}{GLOBAL};
        $self->{+GLOBALS}->{$hid}->{$name}++;
    }

    my ($ok, $err) = try {
        Storable::store($e, $file);
        rename($file, $ready) or $self->abort("Could not rename file '$file' -> '$ready'");
        test2_ipc_set_pending(substr($file, -(shm_size)));
    };
    if (!$ok) {
        my $src_file = __FILE__;
        $err =~ s{ at \Q$src_file\E.*$}{};
        chomp($err);
        my $tid = get_tid();
        my $trace = $e->trace->debug;
        my $type = blessed($e);

        $self->abort(<<"        EOT");

*******************************************************************************
There was an error writing an event:
Destination: $dest
Origin PID:  $$
Origin TID:  $tid
Event Type:  $type
Event Trace: $trace
File Name:   $file
Ready Name:  $ready
Error: $err
*******************************************************************************

        EOT
    }

    return 1;
}

sub cull {
    my $self = shift;
    my ($hid) = @_;

    my $tempdir = $self->{+TEMPDIR};

    opendir(my $dh, $tempdir) or $self->abort("could not open IPC temp dir ($tempdir)!");

    my @out;
    for my $file (sort readdir($dh)) {
        next if substr($file, 0, 1) eq '.';

        next unless substr($file, -6, 6) eq '.ready';

        my $global   = substr($file, 0, 6) eq 'GLOBAL';
        my $hid_len = length($hid);
        my $have_hid = !$global && substr($file, 0, $hid_len) eq $hid && substr($file, $hid_len, 1) eq '-';

        next unless $have_hid || $global;

        next if $global && $self->{+GLOBALS}->{$hid}->{$file}++;

        # Untaint the path.
        my $full = File::Spec->canonpath("$tempdir/$file");
        ($full) = ($full =~ m/^(.*)$/gs);

        my $obj = $self->read_event_file($full);
        push @out => $obj;

        # Do not remove global events
        next if $global;

        my $complete = File::Spec->canonpath("$full.complete");
        if ($ENV{T2_KEEP_TEMPDIR}) {
            rename($full, $complete) or $self->abort("Could not rename IPC file '$full', '$complete'");
        }
        else {
            unlink($full) or $self->abort("Could not unlink IPC file: $file");
        }
    }

    closedir($dh);
    return @out;
}

sub read_event_file {
    my $self = shift;
    my ($file) = @_;

    my $obj = Storable::retrieve($file);
    $self->abort("Got an unblessed object: '$obj'")
        unless blessed($obj);

    unless ($obj->isa('Test2::Event')) {
        my $pkg  = blessed($obj);
        my $mod_file = pkg_to_file($pkg);
        my ($ok, $err) = try { require $mod_file };

        $self->abort("Event has unknown type ($pkg), tried to load '$mod_file' but failed: $err")
            unless $ok;

        $self->abort("'$obj' is not a 'Test2::Event' object")
            unless $obj->isa('Test2::Event');
    }

    return $obj;
}

sub waiting {
    my $self = shift;
    require Test2::Event::Waiting;
    $self->send(
        GLOBAL => Test2::Event::Waiting->new(
            trace => Test2::Util::Trace->new(frame => [caller()]),
        ),
        'GLOBAL'
    );
    return;
}

sub DESTROY {
    my $self = shift;

    return unless defined $self->pid;
    return unless defined $self->tid;

    return unless $$        == $self->pid;
    return unless get_tid() == $self->tid;

    my $tempdir = $self->{+TEMPDIR};

    opendir(my $dh, $tempdir) or $self->abort("Could not open temp dir! ($tempdir)");
    while(my $file = readdir($dh)) {
        next if $file =~ m/^\.+$/;
        next if $file =~ m/\.complete$/;
        my $full = File::Spec->canonpath("$tempdir/$file");

        if ($file =~ m/^(GLOBAL|HUB-)/) {
            $full =~ m/^(.*)$/;
            $full = $1; # Untaint it
            next if $ENV{T2_KEEP_TEMPDIR};
            unlink($full) or $self->abort("Could not unlink IPC file: $full");
            next;
        }

        $self->abort("Leftover files in the directory ($full)!\n");
    }
    closedir($dh);

    if ($ENV{T2_KEEP_TEMPDIR}) {
        print STDERR "# Not removing temp dir: $tempdir\n";
        return;
    }

    rmdir($tempdir) or warn "Could not remove IPC temp dir ($tempdir)";
}

1;

__END__