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