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