cpan/Test-Simple/lib/Test2/Util.pm

   1 package Test2::Util;
   2 use strict;
   3 use warnings;
   4
   5 our $VERSION = '1.302071';
   6
   7
   8 use Config qw/%Config/;
   9
  10 our @EXPORT_OK = qw{
  11     try
  12
  13     pkg_to_file
  14
  15     get_tid USE_THREADS
  16     CAN_THREAD
  17     CAN_REALLY_FORK
  18     CAN_FORK
  19
  20     IS_WIN32
  21
  22     ipc_separator
  23 };
  24 BEGIN { require Exporter; our @ISA = qw(Exporter) }
  25
  26 BEGIN {
  27     *IS_WIN32 = ($^O eq 'MSWin32') ? sub() { 1 } : sub() { 0 };
  28 }
  29
  30 sub _can_thread {
  31     return 0 unless $] >= 5.008001;
  32     return 0 unless $Config{'useithreads'};
  33
  34     # Threads are broken on perl 5.10.0 built with gcc 4.8+
  35     if ($] == 5.010000 && $Config{'ccname'} eq 'gcc' && $Config{'gccversion'}) {
  36         my @parts = split /\./, $Config{'gccversion'};
  37         return 0 if $parts[0] > 4 || ($parts[0] == 4 && $parts[1] >= 8);
  38     }
  39
  40     # Change to a version check if this ever changes
  41     return 0 if $INC{'Devel/Cover.pm'};
  42     return 1;
  43 }
  44
  45 sub _can_fork {
  46     return 1 if $Config{d_fork};
  47     return 0 unless IS_WIN32 || $^O eq 'NetWare';
  48     return 0 unless $Config{useithreads};
  49     return 0 unless $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/;
  50
  51     return _can_thread();
  52 }
  53
  54 BEGIN {
  55     no warnings 'once';
  56     *CAN_THREAD      = _can_thread()   ? sub() { 1 } : sub() { 0 };
  57 }
  58 my $can_fork;
  59 sub CAN_FORK () {
  60     return $can_fork
  61         if defined $can_fork;
  62     $can_fork = !!_can_fork();
  63     no warnings 'redefine';
  64     *CAN_FORK = $can_fork ? sub() { 1 } : sub() { 0 };
  65     $can_fork;
  66 }
  67 my $can_really_fork;
  68 sub CAN_REALLY_FORK () {
  69     return $can_really_fork
  70         if defined $can_really_fork;
  71     $can_really_fork = !!$Config{d_fork};
  72     no warnings 'redefine';
  73     *CAN_REALLY_FORK = $can_really_fork ? sub() { 1 } : sub() { 0 };
  74     $can_really_fork;
  75 }
  76
  77 sub _manual_try(&;@) {
  78     my $code = shift;
  79     my $args = \@_;
  80     my $err;
  81
  82     my $die = delete $SIG{__DIE__};
  83
  84     eval { $code->(@$args); 1 } or $err = $@ || "Error was squashed!\n";
  85
  86     $die ? $SIG{__DIE__} = $die : delete $SIG{__DIE__};
  87
  88     return (!defined($err), $err);
  89 }
  90
  91 sub _local_try(&;@) {
  92     my $code = shift;
  93     my $args = \@_;
  94     my $err;
  95
  96     no warnings;
  97     local $SIG{__DIE__};
  98     eval { $code->(@$args); 1 } or $err = $@ || "Error was squashed!\n";
  99
 100     return (!defined($err), $err);
 101 }
 102
 103 # Older versions of perl have a nasty bug on win32 when localizing a variable
 104 # before forking or starting a new thread. So for those systems we use the
 105 # non-local form. When possible though we use the faster 'local' form.
 106 BEGIN {
 107     if (IS_WIN32 && $] < 5.020002) {
 108         *try = \&_manual_try;
 109     }
 110     else {
 111         *try = \&_local_try;
 112     }
 113 }
 114
 115 BEGIN {
 116     if (CAN_THREAD) {
 117         if ($INC{'threads.pm'}) {
 118             # Threads are already loaded, so we do not need to check if they
 119             # are loaded each time
 120             *USE_THREADS = sub() { 1 };
 121             *get_tid     = sub() { threads->tid() };
 122         }
 123         else {
 124             # :-( Need to check each time to see if they have been loaded.
 125             *USE_THREADS = sub() { $INC{'threads.pm'} ? 1 : 0 };
 126             *get_tid     = sub() { $INC{'threads.pm'} ? threads->tid() : 0 };
 127         }
 128     }
 129     else {
 130         # No threads, not now, not ever!
 131         *USE_THREADS = sub() { 0 };
 132         *get_tid     = sub() { 0 };
 133     }
 134 }
 135
 136 sub pkg_to_file {
 137     my $pkg = shift;
 138     my $file = $pkg;
 139     $file =~ s{(::|')}{/}g;
 140     $file .= '.pm';
 141     return $file;
 142 }
 143
 144 sub ipc_separator() { "~" }
 145
 146 1;
 147
 148 __END__
 149
 150 =pod
 151
 152 =encoding UTF-8
 153
 154 =head1 NAME
 155
 156 Test2::Util - Tools used by Test2 and friends.
 157
 158 =head1 DESCRIPTION
 159
 160 Collection of tools used by L<Test2> and friends.
 161
 162 =head1 EXPORTS
 163
 164 All exports are optional. You must specify subs to import.
 165
 166 =over 4
 167
 168 =item ($success, $error) = try { ... }
 169
 170 Eval the codeblock, return success or failure, and the error message. This code
 171 protects $@ and $!, they will be restored by the end of the run. This code also
 172 temporarily blocks $SIG{DIE} handlers.
 173
 174 =item protect { ... }
 175
 176 Similar to try, except that it does not catch exceptions. The idea here is to
 177 protect $@ and $! from changes. $@ and $! will be restored to whatever they
 178 were before the run so long as it is successful. If the run fails $! will still
 179 be restored, but $@ will contain the exception being thrown.
 180
 181 =item CAN_FORK
 182
 183 True if this system is capable of true or pseudo-fork.
 184
 185 =item CAN_REALLY_FORK
 186
 187 True if the system can really fork. This will be false for systems where fork
 188 is emulated.
 189
 190 =item CAN_THREAD
 191
 192 True if this system is capable of using threads.
 193
 194 =item USE_THREADS
 195
 196 Returns true if threads are enabled, false if they are not.
 197
 198 =item get_tid
 199
 200 This will return the id of the current thread when threads are enabled,
 201 otherwise it returns 0.
 202
 203 =item my $file = pkg_to_file($package)
 204
 205 Convert a package name to a filename.
 206
 207 =back
 208
 209 =head1 NOTES && CAVEATS
 210
 211 =over 4
 212
 213 =item 5.10.0
 214
 215 Perl 5.10.0 has a bug when compiled with newer gcc versions. This bug causes a
 216 segfault whenever a new thread is launched. Test2 will attempt to detect
 217 this, and note that the system is not capable of forking when it is detected.
 218
 219 =item Devel::Cover
 220
 221 Devel::Cover does not support threads. CAN_THREAD will return false if
 222 Devel::Cover is loaded before the check is first run.
 223
 224 =back
 225
 226 =head1 SOURCE
 227
 228 The source code repository for Test2 can be found at
 229 F<http://github.com/Test-More/test-more/>.
 230
 231 =head1 MAINTAINERS
 232
 233 =over 4
 234
 235 =item Chad Granum E<lt>exodist@cpan.orgE<gt>
 236
 237 =back
 238
 239 =head1 AUTHORS
 240
 241 =over 4
 242
 243 =item Chad Granum E<lt>exodist@cpan.orgE<gt>
 244
 245 =item Kent Fredric E<lt>kentnl@cpan.orgE<gt>
 246
 247 =back
 248
 249 =head1 COPYRIGHT
 250
 251 Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>.
 252
 253 This program is free software; you can redistribute it and/or
 254 modify it under the same terms as Perl itself.
 255
 256 See F<http://dev.perl.org/licenses/>
 257
 258 =cut