| Filename | /home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/Test2/Util.pm |
| Statements | Executed 109 statements in 1.84ms |
| Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
|---|---|---|---|---|---|
| 1 | 1 | 1 | 2.52ms | 7.23ms | Test2::Util::BEGIN@7 |
| 1 | 1 | 1 | 439µs | 495µs | Test2::Util::BEGIN@8 |
| 1 | 1 | 1 | 195µs | 202µs | Test2::Util::BEGIN@11 |
| 4 | 4 | 2 | 60µs | 129µs | Test2::Util::clone_io |
| 8 | 3 | 3 | 19µs | 19µs | Test2::Util::gen_uid |
| 1 | 1 | 1 | 17µs | 1.73ms | Test2::Util::BEGIN@171 |
| 1 | 1 | 1 | 10µs | 12µs | Test2::Util::BEGIN@2 |
| 1 | 1 | 1 | 8µs | 16µs | Test2::Util::BEGIN@71 |
| 1 | 1 | 1 | 7µs | 7µs | Test2::Util::BEGIN@40 |
| 1 | 1 | 1 | 6µs | 6µs | Test2::Util::BEGIN@206 |
| 1 | 1 | 1 | 6µs | 8µs | Test2::Util::_can_thread |
| 1 | 1 | 1 | 5µs | 17µs | Test2::Util::BEGIN@113 |
| 1 | 1 | 1 | 5µs | 20µs | Test2::Util::BEGIN@72 |
| 1 | 1 | 1 | 5µs | 1.71ms | Test2::Util::_check_for_sig_sys |
| 1 | 1 | 1 | 4µs | 31µs | Test2::Util::BEGIN@9 |
| 1 | 1 | 1 | 4µs | 16µs | Test2::Util::BEGIN@80 |
| 1 | 1 | 1 | 4µs | 16µs | Test2::Util::BEGIN@89 |
| 1 | 1 | 1 | 4µs | 4µs | Test2::Util::BEGIN@123 |
| 1 | 1 | 1 | 3µs | 3µs | Test2::Util::BEGIN@132 |
| 1 | 1 | 1 | 3µs | 3µs | Test2::Util::BEGIN@42 |
| 1 | 1 | 1 | 3µs | 18µs | Test2::Util::BEGIN@3 |
| 1 | 1 | 1 | 800ns | 800ns | Test2::Util::__ANON__ (xsub) |
| 0 | 0 | 0 | 0s | 0s | Test2::Util::CAN_FORK |
| 0 | 0 | 0 | 0s | 0s | Test2::Util::CAN_REALLY_FORK |
| 0 | 0 | 0 | 0s | 0s | Test2::Util::__ANON__[:138] |
| 0 | 0 | 0 | 0s | 0s | Test2::Util::__ANON__[:142] |
| 0 | 0 | 0 | 0s | 0s | Test2::Util::__ANON__[:143] |
| 0 | 0 | 0 | 0s | 0s | Test2::Util::__ANON__[:222] |
| 0 | 0 | 0 | 0s | 0s | Test2::Util::__ANON__[:235] |
| 0 | 0 | 0 | 0s | 0s | Test2::Util::__ANON__[:242] |
| 0 | 0 | 0 | 0s | 0s | Test2::Util::__ANON__[:247] |
| 0 | 0 | 0 | 0s | 0s | Test2::Util::_can_fork |
| 0 | 0 | 0 | 0s | 0s | Test2::Util::_local_try |
| 0 | 0 | 0 | 0s | 0s | Test2::Util::_manual_try |
| 0 | 0 | 0 | 0s | 0s | Test2::Util::pkg_to_file |
| 0 | 0 | 0 | 0s | 0s | Test2::Util::try_sig_mask |
| Line | State ments |
Time on line |
Calls | Time in subs |
Code |
|---|---|---|---|---|---|
| 1 | package Test2::Util; | ||||
| 2 | 2 | 20µs | 2 | 14µs | # spent 12µs (10+2) within Test2::Util::BEGIN@2 which was called:
# once (10µs+2µs) by Test::Builder::BEGIN@17 at line 2 # spent 12µs making 1 call to Test2::Util::BEGIN@2
# spent 2µs making 1 call to strict::import |
| 3 | 2 | 22µs | 2 | 32µs | # spent 18µs (3+15) within Test2::Util::BEGIN@3 which was called:
# once (3µs+15µs) by Test::Builder::BEGIN@17 at line 3 # spent 18µs making 1 call to Test2::Util::BEGIN@3
# spent 15µs making 1 call to warnings::import |
| 4 | |||||
| 5 | 1 | 300ns | our $VERSION = '1.302198'; | ||
| 6 | |||||
| 7 | 2 | 95µs | 1 | 7.23ms | # spent 7.23ms (2.52+4.71) within Test2::Util::BEGIN@7 which was called:
# once (2.52ms+4.71ms) by Test::Builder::BEGIN@17 at line 7 # spent 7.23ms making 1 call to Test2::Util::BEGIN@7 |
| 8 | 2 | 85µs | 2 | 502µs | # spent 495µs (439+57) within Test2::Util::BEGIN@8 which was called:
# once (439µs+57µs) by Test::Builder::BEGIN@17 at line 8 # spent 495µs making 1 call to Test2::Util::BEGIN@8
# spent 7µs making 1 call to Config::import |
| 9 | 2 | 53µs | 2 | 58µs | # spent 31µs (4+27) within Test2::Util::BEGIN@9 which was called:
# once (4µs+27µs) by Test::Builder::BEGIN@17 at line 9 # spent 31µs making 1 call to Test2::Util::BEGIN@9
# spent 27µs making 1 call to Exporter::import |
| 10 | |||||
| 11 | # spent 202µs (195+7) within Test2::Util::BEGIN@11 which was called:
# once (195µs+7µs) by Test::Builder::BEGIN@17 at line 14 | ||||
| 12 | 1 | 2µs | local ($@, $!, $SIG{__DIE__}); | ||
| 13 | 3 | 196µs | 1 | 7µs | *HAVE_PERLIO = eval { require PerlIO; PerlIO->VERSION(1.02); } ? sub() { 1 } : sub() { 0 }; # spent 7µs making 1 call to UNIVERSAL::VERSION |
| 14 | 1 | 44µs | 1 | 202µs | } # spent 202µs making 1 call to Test2::Util::BEGIN@11 |
| 15 | |||||
| 16 | 1 | 1µs | 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 | 2 | 40µs | 1 | 7µs | # spent 7µs within Test2::Util::BEGIN@40 which was called:
# once (7µs+0s) by Test::Builder::BEGIN@17 at line 40 # spent 7µs making 1 call to Test2::Util::BEGIN@40 |
| 41 | |||||
| 42 | # spent 3µs within Test2::Util::BEGIN@42 which was called:
# once (3µs+0s) by Test::Builder::BEGIN@17 at line 44 | ||||
| 43 | 1 | 4µs | *IS_WIN32 = ($^O eq 'MSWin32') ? sub() { 1 } : sub() { 0 }; | ||
| 44 | 1 | 154µs | 1 | 3µs | } # spent 3µs making 1 call to Test2::Util::BEGIN@42 |
| 45 | |||||
| 46 | # spent 8µs (6+2) within Test2::Util::_can_thread which was called:
# once (6µs+2µs) by Test2::Util::BEGIN@71 at line 73 | ||||
| 47 | 1 | 200ns | return 0 unless $] >= 5.008001; | ||
| 48 | 1 | 9µs | 1 | 2µs | return 0 unless $Config{'useithreads'}; # spent 2µs making 1 call to Config::FETCH |
| 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 | |||||
| 62 | sub _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 | |||||
| 71 | # spent 16µs (8+8) within Test2::Util::BEGIN@71 which was called:
# once (8µs+8µs) by Test::Builder::BEGIN@17 at line 74 | ||||
| 72 | 2 | 34µs | 2 | 35µs | # spent 20µs (5+15) within Test2::Util::BEGIN@72 which was called:
# once (5µs+15µs) by Test::Builder::BEGIN@17 at line 72 # spent 20µs making 1 call to Test2::Util::BEGIN@72
# spent 15µs making 1 call to warnings::unimport |
| 73 | 1 | 2µs | 1 | 8µs | *CAN_THREAD = _can_thread() ? sub() { 1 } : sub() { 0 }; # spent 8µs making 1 call to Test2::Util::_can_thread |
| 74 | 1 | 33µs | 1 | 16µs | } # spent 16µs making 1 call to Test2::Util::BEGIN@71 |
| 75 | 1 | 200ns | my $can_fork; | ||
| 76 | sub CAN_FORK () { | ||||
| 77 | return $can_fork | ||||
| 78 | if defined $can_fork; | ||||
| 79 | $can_fork = !!_can_fork(); | ||||
| 80 | 2 | 58µs | 2 | 28µs | # spent 16µs (4+12) within Test2::Util::BEGIN@80 which was called:
# once (4µs+12µs) by Test::Builder::BEGIN@17 at line 80 # spent 16µs making 1 call to Test2::Util::BEGIN@80
# spent 12µs making 1 call to warnings::unimport |
| 81 | *CAN_FORK = $can_fork ? sub() { 1 } : sub() { 0 }; | ||||
| 82 | $can_fork; | ||||
| 83 | } | ||||
| 84 | my $can_really_fork; | ||||
| 85 | sub CAN_REALLY_FORK () { | ||||
| 86 | return $can_really_fork | ||||
| 87 | if defined $can_really_fork; | ||||
| 88 | $can_really_fork = !!$Config{d_fork}; | ||||
| 89 | 2 | 112µs | 2 | 27µs | # spent 16µs (4+12) within Test2::Util::BEGIN@89 which was called:
# once (4µs+12µs) by Test::Builder::BEGIN@17 at line 89 # spent 16µs making 1 call to Test2::Util::BEGIN@89
# spent 12µs making 1 call to warnings::unimport |
| 90 | *CAN_REALLY_FORK = $can_really_fork ? sub() { 1 } : sub() { 0 }; | ||||
| 91 | $can_really_fork; | ||||
| 92 | } | ||||
| 93 | |||||
| 94 | sub _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 | |||||
| 108 | sub _local_try(&;@) { | ||||
| 109 | my $code = shift; | ||||
| 110 | my $args = \@_; | ||||
| 111 | my $err; | ||||
| 112 | |||||
| 113 | 2 | 103µs | 2 | 29µs | # spent 17µs (5+12) within Test2::Util::BEGIN@113 which was called:
# once (5µs+12µs) by Test::Builder::BEGIN@17 at line 113 # spent 17µs making 1 call to Test2::Util::BEGIN@113
# spent 12µs making 1 call to warnings::unimport |
| 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. | ||||
| 123 | # spent 4µs within Test2::Util::BEGIN@123 which was called:
# once (4µs+0s) by Test::Builder::BEGIN@17 at line 130 | ||||
| 124 | 1 | 3µs | if (IS_WIN32 && $] < 5.020002) { | ||
| 125 | *try = \&_manual_try; | ||||
| 126 | } | ||||
| 127 | else { | ||||
| 128 | 1 | 1µs | *try = \&_local_try; | ||
| 129 | } | ||||
| 130 | 1 | 93µs | 1 | 4µs | } # spent 4µs making 1 call to Test2::Util::BEGIN@123 |
| 131 | |||||
| 132 | # spent 3µs within Test2::Util::BEGIN@132 which was called:
# once (3µs+0s) by Test::Builder::BEGIN@17 at line 151 | ||||
| 133 | 1 | 2µs | 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 | 1 | 600ns | *USE_THREADS = sub() { 0 }; | ||
| 149 | 1 | 200ns | *get_tid = sub() { 0 }; | ||
| 150 | } | ||||
| 151 | 1 | 166µs | 1 | 3µs | } # spent 3µs making 1 call to Test2::Util::BEGIN@132 |
| 152 | |||||
| 153 | sub pkg_to_file { | ||||
| 154 | my $pkg = shift; | ||||
| 155 | my $file = $pkg; | ||||
| 156 | $file =~ s{(::|')}{/}g; | ||||
| 157 | $file .= '.pm'; | ||||
| 158 | return $file; | ||||
| 159 | } | ||||
| 160 | |||||
| 161 | sub ipc_separator() { "~" } | ||||
| 162 | |||||
| 163 | 1 | 300ns | my $UID = 1; | ||
| 164 | 8 | 26µs | # spent 19µs within Test2::Util::gen_uid which was called 8 times, avg 2µs/call:
# 4 times (10µs+0s) by Test2::API::context at line 485 of Test2/API.pm, avg 2µs/call
# 3 times (6µs+0s) by Test2::Event::eid at line 123 of Test2/Event.pm, avg 2µs/call
# once (3µs+0s) by Test2::Hub::init at line 46 of Test2/Hub.pm | ||
| 165 | |||||
| 166 | # spent 1.71ms (5µs+1.71) within Test2::Util::_check_for_sig_sys which was called:
# once (5µs+1.71ms) by Test2::Util::BEGIN@171 at line 172 | ||||
| 167 | 1 | 2µs | 1 | 1.71ms | my $sig_list = shift; # spent 1.71ms making 1 call to Config::FETCH |
| 168 | 1 | 4µs | 1 | 1µs | return $sig_list =~ m/\bSYS\b/; # spent 1µs making 1 call to CORE::match |
| 169 | } | ||||
| 170 | |||||
| 171 | # spent 1.73ms (17µs+1.71) within Test2::Util::BEGIN@171 which was called:
# once (17µs+1.71ms) by Test::Builder::BEGIN@17 at line 178 | ||||
| 172 | 1 | 4µs | 1 | 1.71ms | if (_check_for_sig_sys($Config{sig_name})) { # spent 1.71ms making 1 call to Test2::Util::_check_for_sig_sys |
| 173 | *CAN_SIGSYS = sub() { 1 }; | ||||
| 174 | } | ||||
| 175 | else { | ||||
| 176 | *CAN_SIGSYS = sub() { 0 }; | ||||
| 177 | } | ||||
| 178 | 1 | 248µs | 1 | 1.73ms | } # spent 1.73ms making 1 call to Test2::Util::BEGIN@171 |
| 179 | |||||
| 180 | 1 | 1µs | my %PERLIO_SKIP = ( | ||
| 181 | unix => 1, | ||||
| 182 | via => 1, | ||||
| 183 | ); | ||||
| 184 | |||||
| 185 | # spent 129µs (60+69) within Test2::Util::clone_io which was called 4 times, avg 32µs/call:
# once (22µs+26µs) by Test::Builder::BEGIN@18 at line 186 of Test2/API.pm
# once (16µs+20µs) by Test2::Formatter::TAP::_open_handles at line 57 of Test2/Formatter/TAP.pm
# once (10µs+12µs) by Test2::Formatter::TAP::_open_handles at line 58 of Test2/Formatter/TAP.pm
# once (11µs+11µs) by Test::Builder::BEGIN@18 at line 187 of Test2/API.pm | ||||
| 186 | 4 | 1µs | my ($fh) = @_; | ||
| 187 | 8 | 4µs | my $fileno = eval { fileno($fh) }; | ||
| 188 | |||||
| 189 | 4 | 3µs | return $fh if !defined($fileno) || !length($fileno) || $fileno < 0; | ||
| 190 | |||||
| 191 | 4 | 59µs | 4 | 47µs | open(my $out, '>&' . $fileno) or die "Can't dup fileno $fileno: $!"; # spent 47µs making 4 calls to CORE::open, avg 12µs/call |
| 192 | |||||
| 193 | 4 | 600ns | my %seen; | ||
| 194 | 4 | 19µs | 4 | 7µs | my @layers = HAVE_PERLIO ? grep { !$PERLIO_SKIP{$_} and !$seen{$_}++ } PerlIO::get_layers($fh) : (); # spent 7µs making 4 calls to PerlIO::get_layers, avg 2µs/call |
| 195 | 4 | 18µs | 4 | 12µs | binmode($out, join(":", "", "raw", @layers)); # spent 12µs making 4 calls to CORE::binmode, avg 3µs/call |
| 196 | |||||
| 197 | 4 | 7µs | 4 | 3µs | my $old = select $fh; # spent 3µs making 4 calls to CORE::select, avg 650ns/call |
| 198 | 4 | 2µs | my $af = $|; | ||
| 199 | 4 | 4µs | 4 | 900ns | select $out; # spent 900ns making 4 calls to CORE::select, avg 225ns/call |
| 200 | 4 | 1µs | $| = $af; | ||
| 201 | 4 | 4µs | 4 | 500ns | select $old; # spent 500ns making 4 calls to CORE::select, avg 125ns/call |
| 202 | |||||
| 203 | 4 | 8µs | return $out; | ||
| 204 | } | ||||
| 205 | |||||
| 206 | # spent 6µs within Test2::Util::BEGIN@206 which was called:
# once (6µs+0s) by Test::Builder::BEGIN@17 at line 249 | ||||
| 207 | 1 | 3µs | 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 | 1 | 3µs | }; | ||
| 243 | *do_unlink = sub { | ||||
| 244 | my ($file) = @_; | ||||
| 245 | return (1) if unlink($file); | ||||
| 246 | return (0, "$!"); | ||||
| 247 | 1 | 800ns | }; | ||
| 248 | } | ||||
| 249 | 1 | 79µs | 1 | 6µs | } # spent 6µs making 1 call to Test2::Util::BEGIN@206 |
| 250 | |||||
| 251 | sub 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 | |||||
| 277 | 1 | 4µs | 1; | ||
| 278 | |||||
| 279 | __END__ | ||||
# spent 800ns within Test2::Util::__ANON__ which was called:
# once (800ns+0s) by Test2::API::test2_set_is_end at line 36 of Test2/API.pm |