1package Test2::Util;
2use strict;
3use warnings;
4
5our $VERSION = '1.302133';
6
7use POSIX();
8use Config qw/%Config/;
9use Carp qw/croak/;
10
11BEGIN {
12    local ($@, $!, $SIG{__DIE__});
13    *HAVE_PERLIO = eval { require PerlIO; PerlIO->VERSION(1.02); } ? sub() { 1 } : sub() { 0 };
14}
15
16our @EXPORT_OK = qw{
17    try
18
19    pkg_to_file
20
21    get_tid USE_THREADS
22    CAN_THREAD
23    CAN_REALLY_FORK
24    CAN_FORK
25
26    CAN_SIGSYS
27
28    IS_WIN32
29
30    ipc_separator
31
32    do_rename do_unlink
33
34    try_sig_mask
35
36    clone_io
37};
38BEGIN { require Exporter; our @ISA = qw(Exporter) }
39
40BEGIN {
41    *IS_WIN32 = ($^O eq 'MSWin32') ? sub() { 1 } : sub() { 0 };
42}
43
44sub _can_thread {
45    return 0 unless $] >= 5.008001;
46    return 0 unless $Config{'useithreads'};
47
48    # Threads are broken on perl 5.10.0 built with gcc 4.8+
49    if ($] == 5.010000 && $Config{'ccname'} eq 'gcc' && $Config{'gccversion'}) {
50        my @parts = split /\./, $Config{'gccversion'};
51        return 0 if $parts[0] > 4 || ($parts[0] == 4 && $parts[1] >= 8);
52    }
53
54    # Change to a version check if this ever changes
55    return 0 if $INC{'Devel/Cover.pm'};
56    return 1;
57}
58
59sub _can_fork {
60    return 1 if $Config{d_fork};
61    return 0 unless IS_WIN32 || $^O eq 'NetWare';
62    return 0 unless $Config{useithreads};
63    return 0 unless $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/;
64
65    return _can_thread();
66}
67
68BEGIN {
69    no warnings 'once';
70    *CAN_THREAD      = _can_thread()   ? sub() { 1 } : sub() { 0 };
71}
72my $can_fork;
73sub CAN_FORK () {
74    return $can_fork
75        if defined $can_fork;
76    $can_fork = !!_can_fork();
77    no warnings 'redefine';
78    *CAN_FORK = $can_fork ? sub() { 1 } : sub() { 0 };
79    $can_fork;
80}
81my $can_really_fork;
82sub CAN_REALLY_FORK () {
83    return $can_really_fork
84        if defined $can_really_fork;
85    $can_really_fork = !!$Config{d_fork};
86    no warnings 'redefine';
87    *CAN_REALLY_FORK = $can_really_fork ? sub() { 1 } : sub() { 0 };
88    $can_really_fork;
89}
90
91sub _manual_try(&;@) {
92    my $code = shift;
93    my $args = \@_;
94    my $err;
95
96    my $die = delete $SIG{__DIE__};
97
98    eval { $code->(@$args); 1 } or $err = $@ || "Error was squashed!\n";
99
100    $die ? $SIG{__DIE__} = $die : delete $SIG{__DIE__};
101
102    return (!defined($err), $err);
103}
104
105sub _local_try(&;@) {
106    my $code = shift;
107    my $args = \@_;
108    my $err;
109
110    no warnings;
111    local $SIG{__DIE__};
112    eval { $code->(@$args); 1 } or $err = $@ || "Error was squashed!\n";
113
114    return (!defined($err), $err);
115}
116
117# Older versions of perl have a nasty bug on win32 when localizing a variable
118# before forking or starting a new thread. So for those systems we use the
119# non-local form. When possible though we use the faster 'local' form.
120BEGIN {
121    if (IS_WIN32 && $] < 5.020002) {
122        *try = \&_manual_try;
123    }
124    else {
125        *try = \&_local_try;
126    }
127}
128
129BEGIN {
130    if (CAN_THREAD) {
131        if ($INC{'threads.pm'}) {
132            # Threads are already loaded, so we do not need to check if they
133            # are loaded each time
134            *USE_THREADS = sub() { 1 };
135            *get_tid     = sub() { threads->tid() };
136        }
137        else {
138            # :-( Need to check each time to see if they have been loaded.
139            *USE_THREADS = sub() { $INC{'threads.pm'} ? 1 : 0 };
140            *get_tid     = sub() { $INC{'threads.pm'} ? threads->tid() : 0 };
141        }
142    }
143    else {
144        # No threads, not now, not ever!
145        *USE_THREADS = sub() { 0 };
146        *get_tid     = sub() { 0 };
147    }
148}
149
150sub pkg_to_file {
151    my $pkg = shift;
152    my $file = $pkg;
153    $file =~ s{(::|')}{/}g;
154    $file .= '.pm';
155    return $file;
156}
157
158sub ipc_separator() { "~" }
159
160sub _check_for_sig_sys {
161    my $sig_list = shift;
162    return $sig_list =~ m/\bSYS\b/;
163}
164
165BEGIN {
166    if (_check_for_sig_sys($Config{sig_name})) {
167        *CAN_SIGSYS = sub() { 1 };
168    }
169    else {
170        *CAN_SIGSYS = sub() { 0 };
171    }
172}
173
174my %PERLIO_SKIP = (
175    unix => 1,
176    via  => 1,
177);
178
179sub clone_io {
180    my ($fh) = @_;
181    my $fileno = fileno($fh);
182
183    return $fh if !defined($fileno) || !length($fileno) || $fileno < 0;
184
185    open(my $out, '>&' . $fileno) or die "Can't dup fileno $fileno: $!";
186
187    my %seen;
188    my @layers = HAVE_PERLIO ? grep { !$PERLIO_SKIP{$_} and !$seen{$_}++ } PerlIO::get_layers($fh) : ();
189    binmode($out, join(":", "", "raw", @layers));
190
191    my $old = select $fh;
192    my $af  = $|;
193    select $out;
194    $| = $af;
195    select $old;
196
197    return $out;
198}
199
200BEGIN {
201    if (IS_WIN32) {
202        my $max_tries = 5;
203
204        *do_rename = sub {
205            my ($from, $to) = @_;
206
207            my $err;
208            for (1 .. $max_tries) {
209                return (1) if rename($from, $to);
210                $err = "$!";
211                last if $_ == $max_tries;
212                sleep 1;
213            }
214
215            return (0, $err);
216        };
217        *do_unlink = sub {
218            my ($file) = @_;
219
220            my $err;
221            for (1 .. $max_tries) {
222                return (1) if unlink($file);
223                $err = "$!";
224                last if $_ == $max_tries;
225                sleep 1;
226            }
227
228            return (0, "$!");
229        };
230    }
231    else {
232        *do_rename = sub {
233            my ($from, $to) = @_;
234            return (1) if rename($from, $to);
235            return (0, "$!");
236        };
237        *do_unlink = sub {
238            my ($file) = @_;
239            return (1) if unlink($file);
240            return (0, "$!");
241        };
242    }
243}
244
245sub try_sig_mask(&) {
246    my $code = shift;
247
248    my ($old, $blocked);
249    unless(IS_WIN32) {
250        my $to_block = POSIX::SigSet->new(
251            POSIX::SIGINT(),
252            POSIX::SIGALRM(),
253            POSIX::SIGHUP(),
254            POSIX::SIGTERM(),
255            POSIX::SIGUSR1(),
256            POSIX::SIGUSR2(),
257        );
258        $old = POSIX::SigSet->new;
259        $blocked = POSIX::sigprocmask(POSIX::SIG_BLOCK(), $to_block, $old);
260        # Silently go on if we failed to log signals, not much we can do.
261    }
262
263    my ($ok, $err) = &try($code);
264
265    # If our block was successful we want to restore the old mask.
266    POSIX::sigprocmask(POSIX::SIG_SETMASK(), $old, POSIX::SigSet->new()) if defined $blocked;
267
268    return ($ok, $err);
269}
270
2711;
272
273__END__
274
275=pod
276
277=encoding UTF-8
278
279=head1 NAME
280
281Test2::Util - Tools used by Test2 and friends.
282
283=head1 DESCRIPTION
284
285Collection of tools used by L<Test2> and friends.
286
287=head1 EXPORTS
288
289All exports are optional. You must specify subs to import.
290
291=over 4
292
293=item ($success, $error) = try { ... }
294
295Eval the codeblock, return success or failure, and the error message. This code
296protects $@ and $!, they will be restored by the end of the run. This code also
297temporarily blocks $SIG{DIE} handlers.
298
299=item protect { ... }
300
301Similar to try, except that it does not catch exceptions. The idea here is to
302protect $@ and $! from changes. $@ and $! will be restored to whatever they
303were before the run so long as it is successful. If the run fails $! will still
304be restored, but $@ will contain the exception being thrown.
305
306=item CAN_FORK
307
308True if this system is capable of true or pseudo-fork.
309
310=item CAN_REALLY_FORK
311
312True if the system can really fork. This will be false for systems where fork
313is emulated.
314
315=item CAN_THREAD
316
317True if this system is capable of using threads.
318
319=item USE_THREADS
320
321Returns true if threads are enabled, false if they are not.
322
323=item get_tid
324
325This will return the id of the current thread when threads are enabled,
326otherwise it returns 0.
327
328=item my $file = pkg_to_file($package)
329
330Convert a package name to a filename.
331
332=item ($ok, $err) = do_rename($old_name, $new_name)
333
334Rename a file, this wraps C<rename()> in a way that makes it more reliable
335cross-platform when trying to rename files you recently altered.
336
337=item ($ok, $err) = do_unlink($filename)
338
339Unlink a file, this wraps C<unlink()> in a way that makes it more reliable
340cross-platform when trying to unlink files you recently altered.
341
342=item ($ok, $err) = try_sig_mask { ... }
343
344Complete an action with several signals masked, they will be unmasked at the
345end allowing any signals that were intercepted to get handled.
346
347This is primarily used when you need to make several actions atomic (against
348some signals anyway).
349
350Signals that are intercepted:
351
352=over 4
353
354=item SIGINT
355
356=item SIGALRM
357
358=item SIGHUP
359
360=item SIGTERM
361
362=item SIGUSR1
363
364=item SIGUSR2
365
366=back
367
368=back
369
370=head1 NOTES && CAVEATS
371
372=over 4
373
374=item 5.10.0
375
376Perl 5.10.0 has a bug when compiled with newer gcc versions. This bug causes a
377segfault whenever a new thread is launched. Test2 will attempt to detect
378this, and note that the system is not capable of forking when it is detected.
379
380=item Devel::Cover
381
382Devel::Cover does not support threads. CAN_THREAD will return false if
383Devel::Cover is loaded before the check is first run.
384
385=back
386
387=head1 SOURCE
388
389The source code repository for Test2 can be found at
390F<http://github.com/Test-More/test-more/>.
391
392=head1 MAINTAINERS
393
394=over 4
395
396=item Chad Granum E<lt>exodist@cpan.orgE<gt>
397
398=back
399
400=head1 AUTHORS
401
402=over 4
403
404=item Chad Granum E<lt>exodist@cpan.orgE<gt>
405
406=item Kent Fredric E<lt>kentnl@cpan.orgE<gt>
407
408=back
409
410=head1 COPYRIGHT
411
412Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>.
413
414This program is free software; you can redistribute it and/or
415modify it under the same terms as Perl itself.
416
417See F<http://dev.perl.org/licenses/>
418
419=cut
420