summaryrefslogtreecommitdiff
path: root/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Util.pm
blob: 0ba499557a0882dec5fbeb7fc373f800ab1abff9 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
package Test2::Util;
use strict;
use warnings;

our $VERSION = '1.302175';

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

    gen_uid

    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() { "~" }

my $UID = 1;
sub gen_uid() { join ipc_separator() => ($$, get_tid(), time, $UID++) }

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 = eval { 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 $string = ipc_separator()

Get the IPC separator. Currently this is always the string C<'~'>.

=item $string = gen_uid()

Generate a unique id (NOT A UUID). This will typically be the process id, the
thread id, the time, and an incrementing integer all joined with the
C<ipc_separator()>.

These ID's are unique enough for most purposes. For identical ids to be
generated you must have 2 processes with the same PID generate IDs at the same
time with the same current state of the incrementing integer. This is a
perfectly reasonable thing to expect to happen across multiple machines, but is
quite unlikely to happen on one machine.

This can fail to be unique if a process generates an id, calls exec, and does
it again after the exec and it all happens in less than a second. It can also
happen if the systems process id's cycle in less than a second allowing 2
different programs that use this generator to run with the same PID in less
than a second. Both these cases are sufficiently unlikely. If you need
universally unique ids, or ids that are unique in these conditions, look at
L<Data::UUID>.

=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 2019 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