use strict;
use warnings;
-our $VERSION = '1.302026';
+our $VERSION = '1.302133';
BEGIN { require Test2::IPC::Driver; our @ISA = qw(Test2::IPC::Driver) }
-use Test2::Util::HashBase qw{tempdir event_id tid pid globals};
+use Test2::Util::HashBase qw{tempdir event_ids read_ids timeouts tid pid globals};
use Scalar::Util qw/blessed/;
use File::Temp();
use File::Spec();
use POSIX();
-use Test2::Util qw/try get_tid pkg_to_file IS_WIN32/;
+use Test2::Util qw/try get_tid pkg_to_file IS_WIN32 ipc_separator do_rename do_unlink try_sig_mask/;
use Test2::API qw/test2_ipc_set_pending/;
sub use_shm { 1 }
my $self = shift;
my $tmpdir = File::Temp::tempdir(
- $ENV{T2_TEMPDIR_TEMPLATE} || "test2-$$-XXXXXX",
+ $ENV{T2_TEMPDIR_TEMPLATE} || "test2" . ipc_separator . $$ . ipc_separator . "XXXXXX",
CLEANUP => 0,
TMPDIR => 1,
);
print STDERR "\nIPC Temp Dir: $tmpdir\n\n"
if $ENV{T2_KEEP_TEMPDIR};
- $self->{+EVENT_ID} = 1;
+ $self->{+EVENT_IDS} = {};
+ $self->{+READ_IDS} = {};
+ $self->{+TIMEOUTS} = {};
$self->{+TID} = get_tid();
$self->{+PID} = $$;
my $self = shift;
my ($hid) = @_;
my $tdir = $self->{+TEMPDIR};
- return File::Spec->catfile($tdir, "HUB-$hid");
+ return File::Spec->catfile($tdir, "HUB" . ipc_separator . $hid);
}
sub event_file {
$self->abort("'$e' is not an event object!")
unless $type->isa('Test2::Event');
+ my $tid = get_tid();
+ my $eid = $self->{+EVENT_IDS}->{$hid}->{$$}->{$tid} += 1;
+
my @type = split '::', $type;
- my $name = join('-', $hid, $$, get_tid(), $self->{+EVENT_ID}++, @type);
+ my $name = join(ipc_separator, $hid, $$, $tid, $eid, @type);
return File::Spec->catfile($tempdir, $name);
}
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'");
+ my ($ok, $err) = do_rename($hfile, File::Spec->canonpath("$hfile.complete"));
+ $self->abort_trace("Could not rename file '$hfile' -> '$hfile.complete': $err") unless $ok
}
else {
- unlink($hfile) or $self->abort_trace("Could not remove file for hub '$hid'");
+ my ($ok, $err) = do_unlink($hfile);
+ $self->abort_trace("Could not remove file for hub '$hid': $err") unless $ok
}
opendir(my $dh, $tdir) or $self->abort_trace("Could not open temp dir!");
$self->{+GLOBALS}->{$hid}->{$name}++;
}
- my ($old, $blocked);
- unless(IS_WIN32) {
- my $to_block = POSIX::SigSet->new(
- POSIX::SIGINT(),
- POSIX::SIGALRM(),
- POSIX::SIGHUP(),
- POSIX::SIGTERM(),
- POSIX::SIGUSR1(),
- POSIX::SIGUSR2(),
- );
- $old = POSIX::SigSet->new;
- $blocked = POSIX::sigprocmask(POSIX::SIG_BLOCK(), $to_block, $old);
- # Silently go on if we failed to log signals, not much we can do.
- }
-
# Write and rename the file.
- my ($ok, $err) = try {
+ my ($ren_ok, $ren_err);
+ my ($ok, $err) = try_sig_mask {
Storable::store($e, $file);
- rename($file, $ready) or $self->abort("Could not rename file '$file' -> '$ready'");
- test2_ipc_set_pending(substr($file, -(shm_size)));
+ ($ren_ok, $ren_err) = do_rename("$file", $ready);
};
- # If our block was successful we want to restore the old mask.
- POSIX::sigprocmask(POSIX::SIG_SETMASK(), $old, POSIX::SigSet->new()) if defined $blocked;
-
- if (!$ok) {
+ if ($ok) {
+ $self->abort("Could not rename file '$file' -> '$ready': $ren_err") unless $ren_ok;
+ test2_ipc_set_pending(substr($file, -(shm_size)));
+ }
+ else {
my $src_file = __FILE__;
$err =~ s{ at \Q$src_file\E.*$}{};
chomp($err);
return 1;
}
+sub driver_abort {
+ my $self = shift;
+ my ($msg) = @_;
+
+ local ($@, $!, $?, $^E);
+ eval {
+ my $abort = File::Spec->catfile($self->{+TEMPDIR}, "ABORT");
+ open(my $fh, '>>', $abort) or die "Could not open abort file: $!";
+ print $fh $msg, "\n";
+ close($fh) or die "Could not close abort file: $!";
+ 1;
+ } or warn $@;
+}
+
sub cull {
my $self = shift;
my ($hid) = @_;
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 $read = $self->{+READ_IDS};
+ my $timeouts = $self->{+TIMEOUTS};
- 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 '-';
+ my @out;
+ for my $info (sort cmp_events map { $self->should_read_event($hid, $_) } readdir($dh)) {
+ unless ($info->{global}) {
+ my $next = $self->{+READ_IDS}->{$info->{hid}}->{$info->{pid}}->{$info->{tid}} ||= 1;
- next unless $have_hid || $global;
+ $timeouts->{$info->{file}} ||= time;
- next if $global && $self->{+GLOBALS}->{$hid}->{$file}++;
+ if ($next != $info->{eid}) {
+ # Wait up to N seconds for missing events
+ next unless 5 < time - $timeouts->{$info->{file}};
+ $self->abort("Missing event HID: $info->{hid}, PID: $info->{pid}, TID: $info->{tid}, EID: $info->{eid}.");
+ }
- # Untaint the path.
- my $full = File::Spec->catfile($tempdir, $file);
- ($full) = ($full =~ m/^(.*)$/gs);
+ $self->{+READ_IDS}->{$info->{hid}}->{$info->{pid}}->{$info->{tid}} = $info->{eid} + 1;
+ }
+ my $full = $info->{full_path};
my $obj = $self->read_event_file($full);
push @out => $obj;
# Do not remove global events
- next if $global;
+ next if $info->{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'");
+ my $complete = File::Spec->canonpath("$full.complete");
+ my ($ok, $err) = do_rename($full, $complete);
+ $self->abort("Could not rename IPC file '$full', '$complete': $err") unless $ok;
}
else {
- unlink($full) or $self->abort("Could not unlink IPC file: $file");
+ my ($ok, $err) = do_unlink("$full");
+ $self->abort("Could not unlink IPC file '$full': $err") unless $ok;
}
}
return @out;
}
+sub parse_event_filename {
+ my $self = shift;
+ my ($file) = @_;
+
+ # The || is to force 0 in false
+ my $complete = substr($file, -9, 9) eq '.complete' || 0 and substr($file, -9, 9, "");
+ my $ready = substr($file, -6, 6) eq '.ready' || 0 and substr($file, -6, 6, "");
+
+ my @parts = split ipc_separator, $file;
+ my ($global, $hid) = $parts[0] eq 'GLOBAL' ? (1, shift @parts) : (0, join ipc_separator, splice(@parts, 0, 3));
+ my ($pid, $tid, $eid) = splice(@parts, 0, 3);
+ my $type = join '::' => @parts;
+
+ return {
+ file => $file,
+ ready => $ready,
+ complete => $complete,
+ global => $global,
+ type => $type,
+ hid => $hid,
+ pid => $pid,
+ tid => $tid,
+ eid => $eid,
+ };
+}
+
+sub should_read_event {
+ my $self = shift;
+ my ($hid, $file) = @_;
+
+ return if substr($file, 0, 1) eq '.';
+ return if substr($file, 0, 3) eq 'HUB';
+ CORE::exit(255) if $file eq 'ABORT';
+
+ my $parsed = $self->parse_event_filename($file);
+
+ return if $parsed->{complete};
+ return unless $parsed->{ready};
+ return unless $parsed->{global} || $parsed->{hid} eq $hid;
+
+ return if $parsed->{global} && $self->{+GLOBALS}->{$hid}->{$file}++;
+
+ # Untaint the path.
+ my $full = File::Spec->catfile($self->{+TEMPDIR}, $file);
+ ($full) = ($full =~ m/^(.*)$/gs) if ${^TAINT};
+
+ $parsed->{full_path} = $full;
+
+ return $parsed;
+}
+
+sub cmp_events {
+ # Globals first
+ return -1 if $a->{global} && !$b->{global};
+ return 1 if $b->{global} && !$a->{global};
+
+ return $a->{pid} <=> $b->{pid}
+ || $a->{tid} <=> $b->{tid}
+ || $a->{eid} <=> $b->{eid};
+}
+
sub read_event_file {
my $self = shift;
my ($file) = @_;
require Test2::Event::Waiting;
$self->send(
GLOBAL => Test2::Event::Waiting->new(
- trace => Test2::Util::Trace->new(frame => [caller()]),
+ trace => Test2::EventFacet::Trace->new(frame => [caller()]),
),
'GLOBAL'
);
my $tempdir = $self->{+TEMPDIR};
+ my $aborted = 0;
+ my $abort_file = File::Spec->catfile($self->{+TEMPDIR}, "ABORT");
+ if (-e $abort_file) {
+ $aborted = 1;
+ my ($ok, $err) = do_unlink($abort_file);
+ warn $err unless $ok;
+ }
+
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->catfile($tempdir, $file);
- if ($file =~ m/^(GLOBAL|HUB-)/) {
+ my $sep = ipc_separator;
+ if ($aborted || $file =~ m/^(GLOBAL|HUB$sep)/) {
$full =~ m/^(.*)$/;
$full = $1; # Untaint it
next if $ENV{T2_KEEP_TEMPDIR};
- unlink($full) or $self->abort("Could not unlink IPC file: $full");
+ my ($ok, $err) = do_unlink($full);
+ $self->abort("Could not unlink IPC file '$full': $err") unless $ok;
next;
}
return;
}
+ my $abort = File::Spec->catfile($self->{+TEMPDIR}, "ABORT");
+ unlink($abort) if -e $abort;
rmdir($tempdir) or warn "Could not remove IPC temp dir ($tempdir)";
}
=head1 COPYRIGHT
-Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>.
+Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
https://perl5.git.perl.org / perl5.git / blobdiff