Synch with CPAN Test-Simple 1.302140.
[perl.git] / cpan / Test-Simple / lib / Test2 / Util.pm
1 package Test2::Util;
2 use strict;
3 use warnings;
4
5 our $VERSION = '1.302140';
6
7 use POSIX();
8 use Config qw/%Config/;
9 use Carp qw/croak/;
10
11 BEGIN {
12     local ($@, $!, $SIG{__DIE__});
13     *HAVE_PERLIO = eval { require PerlIO; PerlIO->VERSION(1.02); } ? sub() { 1 } : sub() { 0 };
14 }
15
16 our @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 };
40 BEGIN { require Exporter; our @ISA = qw(Exporter) }
41
42 BEGIN {
43     *IS_WIN32 = ($^O eq 'MSWin32') ? sub() { 1 } : sub() { 0 };
44 }
45
46 sub _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
61 sub _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
70 BEGIN {
71     no warnings 'once';
72     *CAN_THREAD      = _can_thread()   ? sub() { 1 } : sub() { 0 };
73 }
74 my $can_fork;
75 sub 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 }
83 my $can_really_fork;
84 sub 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
93 sub _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
107 sub _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.
122 BEGIN {
123     if (IS_WIN32 && $] < 5.020002) {
124         *try = \&_manual_try;
125     }
126     else {
127         *try = \&_local_try;
128     }
129 }
130
131 BEGIN {
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
152 sub pkg_to_file {
153     my $pkg = shift;
154     my $file = $pkg;
155     $file =~ s{(::|')}{/}g;
156     $file .= '.pm';
157     return $file;
158 }
159
160 sub ipc_separator() { "~" }
161
162 my $UID = 1;
163 sub gen_uid() { join ipc_separator() => ($$, get_tid(), time, $UID++) }
164
165 sub _check_for_sig_sys {
166     my $sig_list = shift;
167     return $sig_list =~ m/\bSYS\b/;
168 }
169
170 BEGIN {
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
179 my %PERLIO_SKIP = (
180     unix => 1,
181     via  => 1,
182 );
183
184 sub clone_io {
185     my ($fh) = @_;
186     my $fileno = 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
205 BEGIN {
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
250 sub 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
276 1;
277
278 __END__
279
280 =pod
281
282 =encoding UTF-8
283
284 =head1 NAME
285
286 Test2::Util - Tools used by Test2 and friends.
287
288 =head1 DESCRIPTION
289
290 Collection of tools used by L<Test2> and friends.
291
292 =head1 EXPORTS
293
294 All exports are optional. You must specify subs to import.
295
296 =over 4
297
298 =item ($success, $error) = try { ... }
299
300 Eval the codeblock, return success or failure, and the error message. This code
301 protects $@ and $!, they will be restored by the end of the run. This code also
302 temporarily blocks $SIG{DIE} handlers.
303
304 =item protect { ... }
305
306 Similar to try, except that it does not catch exceptions. The idea here is to
307 protect $@ and $! from changes. $@ and $! will be restored to whatever they
308 were before the run so long as it is successful. If the run fails $! will still
309 be restored, but $@ will contain the exception being thrown.
310
311 =item CAN_FORK
312
313 True if this system is capable of true or pseudo-fork.
314
315 =item CAN_REALLY_FORK
316
317 True if the system can really fork. This will be false for systems where fork
318 is emulated.
319
320 =item CAN_THREAD
321
322 True if this system is capable of using threads.
323
324 =item USE_THREADS
325
326 Returns true if threads are enabled, false if they are not.
327
328 =item get_tid
329
330 This will return the id of the current thread when threads are enabled,
331 otherwise it returns 0.
332
333 =item my $file = pkg_to_file($package)
334
335 Convert a package name to a filename.
336
337 =item $string = ipc_separator()
338
339 Get the IPC separator. Currently this is always the string C<'~'>.
340
341 =item $string = gen_uid()
342
343 Generate a unique id (NOT A UUID). This will typically be the process id, the
344 thread id, the time, and an incrementing integer all joined with the
345 C<ipc_separator()>.
346
347 These ID's are unique enough for most purposes. For identical ids to be
348 generated you must have 2 processes with the same PID generate IDs at the same
349 time with the same current state of the incrementing integer. This is a
350 perfectly reasonable thing to expect to happen across multiple machines, but is
351 quite unlikely to happen on one machine.
352
353 This can fail to be unique if a process generates an id, calls exec, and does
354 it again after the exec and it all happens in less than a second. It can also
355 happen if the systems process id's cycle in less than a second allowing 2
356 different programs that use this generator to run with the same PID in less
357 than a second. Both these cases are sufficiently unlikely. If you need
358 universally unique ids, or ids that are unique in these conditions, look at
359 L<Data::UUID>.
360
361 =item ($ok, $err) = do_rename($old_name, $new_name)
362
363 Rename a file, this wraps C<rename()> in a way that makes it more reliable
364 cross-platform when trying to rename files you recently altered.
365
366 =item ($ok, $err) = do_unlink($filename)
367
368 Unlink a file, this wraps C<unlink()> in a way that makes it more reliable
369 cross-platform when trying to unlink files you recently altered.
370
371 =item ($ok, $err) = try_sig_mask { ... }
372
373 Complete an action with several signals masked, they will be unmasked at the
374 end allowing any signals that were intercepted to get handled.
375
376 This is primarily used when you need to make several actions atomic (against
377 some signals anyway).
378
379 Signals 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
405 Perl 5.10.0 has a bug when compiled with newer gcc versions. This bug causes a
406 segfault whenever a new thread is launched. Test2 will attempt to detect
407 this, and note that the system is not capable of forking when it is detected.
408
409 =item Devel::Cover
410
411 Devel::Cover does not support threads. CAN_THREAD will return false if
412 Devel::Cover is loaded before the check is first run.
413
414 =back
415
416 =head1 SOURCE
417
418 The source code repository for Test2 can be found at
419 F<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
441 Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>.
442
443 This program is free software; you can redistribute it and/or
444 modify it under the same terms as Perl itself.
445
446 See F<http://dev.perl.org/licenses/>
447
448 =cut