summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Test2/IPC/Driver/Files.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Test2/IPC/Driver/Files.pm')
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Test2/IPC/Driver/Files.pm497
1 files changed, 497 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/Test2/IPC/Driver/Files.pm b/Master/tlpkg/tlperl/lib/Test2/IPC/Driver/Files.pm
new file mode 100755
index 00000000000..998fef56376
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Test2/IPC/Driver/Files.pm
@@ -0,0 +1,497 @@
+package Test2::IPC::Driver::Files;
+use strict;
+use warnings;
+
+our $VERSION = '1.302073';
+
+
+BEGIN { require Test2::IPC::Driver; our @ISA = qw(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 POSIX();
+
+use Test2::Util qw/try get_tid pkg_to_file IS_WIN32 ipc_separator/;
+use Test2::API qw/test2_ipc_set_pending/;
+
+BEGIN {
+ if (IS_WIN32) {
+ my $max_tries = 5;
+
+ *do_rename = sub {
+ my ($from, $to) = @_;
+
+ my $err;
+ for (1 .. $max_tries) {
+ return (1) if rename($from, $to);
+ $err = "$!";
+ last if $_ == $max_tries;
+ sleep 1;
+ }
+
+ return (0, $err);
+ };
+ *do_unlink = sub {
+ my ($file) = @_;
+
+ my $err;
+ for (1 .. $max_tries) {
+ return (1) if unlink($file);
+ $err = "$!";
+ last if $_ == $max_tries;
+ sleep 1;
+ }
+
+ return (0, "$!");
+ };
+ }
+ else {
+ *do_rename = sub {
+ my ($from, $to) = @_;
+ return (1) if rename($from, $to);
+ return (0, "$!");
+ };
+ *do_unlink = sub {
+ my ($file) = @_;
+ return (1) if unlink($file);
+ return (0, "$!");
+ };
+ }
+}
+
+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" . ipc_separator . $$ . ipc_separator . "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->catfile($tdir, "HUB" . ipc_separator . $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(ipc_separator, $hid, $$, get_tid(), $self->{+EVENT_ID}++, @type);
+
+ return File::Spec->catfile($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}) {
+ 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 {
+ 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!");
+ 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 ($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 {
+ Storable::store($e, $file);
+ my ($ok, $err) = do_rename("$file", $ready);
+ unless ($ok) {
+ POSIX::sigprocmask(POSIX::SIG_SETMASK(), $old, POSIX::SigSet->new()) if defined $blocked;
+ $self->abort("Could not rename file '$file' -> '$ready': $err");
+ };
+ test2_ipc_set_pending(substr($file, -(shm_size)));
+ };
+
+ # 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) {
+ 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 $info (sort cmp_events map { $self->should_read_event($hid, $_) } readdir($dh)) {
+ my $full = $info->{full_path};
+ my $obj = $self->read_event_file($full);
+ push @out => $obj;
+
+ # Do not remove global events
+ next if $info->{global};
+
+ if ($ENV{T2_KEEP_TEMPDIR}) {
+ 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 {
+ my ($ok, $err) = do_unlink("$full");
+ $self->abort("Could not unlink IPC file '$full': $err") unless $ok;
+ }
+ }
+
+ closedir($dh);
+ 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 {
+ 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 '.';
+
+ 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) = @_;
+
+ 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->catfile($tempdir, $file);
+
+ my $sep = ipc_separator;
+ if ($file =~ m/^(GLOBAL|HUB$sep)/) {
+ $full =~ m/^(.*)$/;
+ $full = $1; # Untaint it
+ next if $ENV{T2_KEEP_TEMPDIR};
+ my ($ok, $err) = do_unlink($full);
+ $self->abort("Could not unlink IPC file '$full': $err") unless $ok;
+ 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__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Test2::IPC::Driver::Files - Temp dir + Files concurrency model.
+
+=head1 DESCRIPTION
+
+This is the default, and fallback concurrency model for L<Test2>. This
+sends events between processes and threads using serialized files in a
+temporary directory. This is not particularly fast, but it works everywhere.
+
+=head1 SYNOPSIS
+
+ use Test2::IPC::Driver::Files;
+
+ # IPC is now enabled
+
+=head1 ENVIRONMENT VARIABLES
+
+=over 4
+
+=item T2_KEEP_TEMPDIR=0
+
+When true, the tempdir used by the IPC driver will not be deleted when the test
+is done.
+
+=item T2_TEMPDIR_TEMPLATE='test2-XXXXXX'
+
+This can be used to set the template for the IPC temp dir. The template should
+follow template specifications from L<File::Temp>.
+
+=back
+
+=head1 SEE ALSO
+
+See L<Test2::IPC::Driver> for methods.
+
+=head1 SOURCE
+
+The source code repository for Test2 can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=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 2016 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.
+
+See F<http://dev.perl.org/licenses/>
+
+=cut