diff options
Diffstat (limited to 'systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Util.pm')
-rw-r--r-- | systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Util.pm | 419 |
1 files changed, 419 insertions, 0 deletions
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Util.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Util.pm new file mode 100644 index 0000000000..6de008b683 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Util.pm @@ -0,0 +1,419 @@ +package Test2::Util; +use strict; +use warnings; + +our $VERSION = '1.302133'; + +use POSIX(); +use Config qw/%Config/; +use Carp qw/croak/; + +BEGIN { + local ($@, $!, $SIG{__DIE__}); + *HAVE_PERLIO = eval { require PerlIO; PerlIO->VERSION(1.02); } ? sub() { 1 } : sub() { 0 }; +} + +our @EXPORT_OK = qw{ + try + + pkg_to_file + + get_tid USE_THREADS + CAN_THREAD + CAN_REALLY_FORK + CAN_FORK + + CAN_SIGSYS + + IS_WIN32 + + ipc_separator + + do_rename do_unlink + + try_sig_mask + + clone_io +}; +BEGIN { require Exporter; our @ISA = qw(Exporter) } + +BEGIN { + *IS_WIN32 = ($^O eq 'MSWin32') ? sub() { 1 } : sub() { 0 }; +} + +sub _can_thread { + return 0 unless $] >= 5.008001; + return 0 unless $Config{'useithreads'}; + + # Threads are broken on perl 5.10.0 built with gcc 4.8+ + if ($] == 5.010000 && $Config{'ccname'} eq 'gcc' && $Config{'gccversion'}) { + my @parts = split /\./, $Config{'gccversion'}; + return 0 if $parts[0] > 4 || ($parts[0] == 4 && $parts[1] >= 8); + } + + # Change to a version check if this ever changes + return 0 if $INC{'Devel/Cover.pm'}; + return 1; +} + +sub _can_fork { + return 1 if $Config{d_fork}; + return 0 unless IS_WIN32 || $^O eq 'NetWare'; + return 0 unless $Config{useithreads}; + return 0 unless $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/; + + return _can_thread(); +} + +BEGIN { + no warnings 'once'; + *CAN_THREAD = _can_thread() ? sub() { 1 } : sub() { 0 }; +} +my $can_fork; +sub CAN_FORK () { + return $can_fork + if defined $can_fork; + $can_fork = !!_can_fork(); + no warnings 'redefine'; + *CAN_FORK = $can_fork ? sub() { 1 } : sub() { 0 }; + $can_fork; +} +my $can_really_fork; +sub CAN_REALLY_FORK () { + return $can_really_fork + if defined $can_really_fork; + $can_really_fork = !!$Config{d_fork}; + no warnings 'redefine'; + *CAN_REALLY_FORK = $can_really_fork ? sub() { 1 } : sub() { 0 }; + $can_really_fork; +} + +sub _manual_try(&;@) { + my $code = shift; + my $args = \@_; + my $err; + + my $die = delete $SIG{__DIE__}; + + eval { $code->(@$args); 1 } or $err = $@ || "Error was squashed!\n"; + + $die ? $SIG{__DIE__} = $die : delete $SIG{__DIE__}; + + return (!defined($err), $err); +} + +sub _local_try(&;@) { + my $code = shift; + my $args = \@_; + my $err; + + no warnings; + local $SIG{__DIE__}; + eval { $code->(@$args); 1 } or $err = $@ || "Error was squashed!\n"; + + return (!defined($err), $err); +} + +# Older versions of perl have a nasty bug on win32 when localizing a variable +# before forking or starting a new thread. So for those systems we use the +# non-local form. When possible though we use the faster 'local' form. +BEGIN { + if (IS_WIN32 && $] < 5.020002) { + *try = \&_manual_try; + } + else { + *try = \&_local_try; + } +} + +BEGIN { + if (CAN_THREAD) { + if ($INC{'threads.pm'}) { + # Threads are already loaded, so we do not need to check if they + # are loaded each time + *USE_THREADS = sub() { 1 }; + *get_tid = sub() { threads->tid() }; + } + else { + # :-( Need to check each time to see if they have been loaded. + *USE_THREADS = sub() { $INC{'threads.pm'} ? 1 : 0 }; + *get_tid = sub() { $INC{'threads.pm'} ? threads->tid() : 0 }; + } + } + else { + # No threads, not now, not ever! + *USE_THREADS = sub() { 0 }; + *get_tid = sub() { 0 }; + } +} + +sub pkg_to_file { + my $pkg = shift; + my $file = $pkg; + $file =~ s{(::|')}{/}g; + $file .= '.pm'; + return $file; +} + +sub ipc_separator() { "~" } + +sub _check_for_sig_sys { + my $sig_list = shift; + return $sig_list =~ m/\bSYS\b/; +} + +BEGIN { + if (_check_for_sig_sys($Config{sig_name})) { + *CAN_SIGSYS = sub() { 1 }; + } + else { + *CAN_SIGSYS = sub() { 0 }; + } +} + +my %PERLIO_SKIP = ( + unix => 1, + via => 1, +); + +sub clone_io { + my ($fh) = @_; + my $fileno = fileno($fh); + + return $fh if !defined($fileno) || !length($fileno) || $fileno < 0; + + open(my $out, '>&' . $fileno) or die "Can't dup fileno $fileno: $!"; + + my %seen; + my @layers = HAVE_PERLIO ? grep { !$PERLIO_SKIP{$_} and !$seen{$_}++ } PerlIO::get_layers($fh) : (); + binmode($out, join(":", "", "raw", @layers)); + + my $old = select $fh; + my $af = $|; + select $out; + $| = $af; + select $old; + + return $out; +} + +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 try_sig_mask(&) { + my $code = shift; + + 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. + } + + my ($ok, $err) = &try($code); + + # If our block was successful we want to restore the old mask. + POSIX::sigprocmask(POSIX::SIG_SETMASK(), $old, POSIX::SigSet->new()) if defined $blocked; + + return ($ok, $err); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Util - Tools used by Test2 and friends. + +=head1 DESCRIPTION + +Collection of tools used by L<Test2> and friends. + +=head1 EXPORTS + +All exports are optional. You must specify subs to import. + +=over 4 + +=item ($success, $error) = try { ... } + +Eval the codeblock, return success or failure, and the error message. This code +protects $@ and $!, they will be restored by the end of the run. This code also +temporarily blocks $SIG{DIE} handlers. + +=item protect { ... } + +Similar to try, except that it does not catch exceptions. The idea here is to +protect $@ and $! from changes. $@ and $! will be restored to whatever they +were before the run so long as it is successful. If the run fails $! will still +be restored, but $@ will contain the exception being thrown. + +=item CAN_FORK + +True if this system is capable of true or pseudo-fork. + +=item CAN_REALLY_FORK + +True if the system can really fork. This will be false for systems where fork +is emulated. + +=item CAN_THREAD + +True if this system is capable of using threads. + +=item USE_THREADS + +Returns true if threads are enabled, false if they are not. + +=item get_tid + +This will return the id of the current thread when threads are enabled, +otherwise it returns 0. + +=item my $file = pkg_to_file($package) + +Convert a package name to a filename. + +=item ($ok, $err) = do_rename($old_name, $new_name) + +Rename a file, this wraps C<rename()> in a way that makes it more reliable +cross-platform when trying to rename files you recently altered. + +=item ($ok, $err) = do_unlink($filename) + +Unlink a file, this wraps C<unlink()> in a way that makes it more reliable +cross-platform when trying to unlink files you recently altered. + +=item ($ok, $err) = try_sig_mask { ... } + +Complete an action with several signals masked, they will be unmasked at the +end allowing any signals that were intercepted to get handled. + +This is primarily used when you need to make several actions atomic (against +some signals anyway). + +Signals that are intercepted: + +=over 4 + +=item SIGINT + +=item SIGALRM + +=item SIGHUP + +=item SIGTERM + +=item SIGUSR1 + +=item SIGUSR2 + +=back + +=back + +=head1 NOTES && CAVEATS + +=over 4 + +=item 5.10.0 + +Perl 5.10.0 has a bug when compiled with newer gcc versions. This bug causes a +segfault whenever a new thread is launched. Test2 will attempt to detect +this, and note that the system is not capable of forking when it is detected. + +=item Devel::Cover + +Devel::Cover does not support threads. CAN_THREAD will return false if +Devel::Cover is loaded before the check is first run. + +=back + +=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> + +=item Kent Fredric E<lt>kentnl@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +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. + +See F<http://dev.perl.org/licenses/> + +=cut |