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 | BEGIN@7 | Test2::Util::
1 | 1 | 1 | 439µs | 495µs | BEGIN@8 | Test2::Util::
1 | 1 | 1 | 195µs | 202µs | BEGIN@11 | Test2::Util::
4 | 4 | 2 | 60µs | 129µs | clone_io | Test2::Util::
8 | 3 | 3 | 19µs | 19µs | gen_uid | Test2::Util::
1 | 1 | 1 | 17µs | 1.73ms | BEGIN@171 | Test2::Util::
1 | 1 | 1 | 10µs | 12µs | BEGIN@2 | Test2::Util::
1 | 1 | 1 | 8µs | 16µs | BEGIN@71 | Test2::Util::
1 | 1 | 1 | 7µs | 7µs | BEGIN@40 | Test2::Util::
1 | 1 | 1 | 6µs | 6µs | BEGIN@206 | Test2::Util::
1 | 1 | 1 | 6µs | 8µs | _can_thread | Test2::Util::
1 | 1 | 1 | 5µs | 17µs | BEGIN@113 | Test2::Util::
1 | 1 | 1 | 5µs | 20µs | BEGIN@72 | Test2::Util::
1 | 1 | 1 | 5µs | 1.71ms | _check_for_sig_sys | Test2::Util::
1 | 1 | 1 | 4µs | 31µs | BEGIN@9 | Test2::Util::
1 | 1 | 1 | 4µs | 16µs | BEGIN@80 | Test2::Util::
1 | 1 | 1 | 4µs | 16µs | BEGIN@89 | Test2::Util::
1 | 1 | 1 | 4µs | 4µs | BEGIN@123 | Test2::Util::
1 | 1 | 1 | 3µs | 3µs | BEGIN@132 | Test2::Util::
1 | 1 | 1 | 3µs | 3µs | BEGIN@42 | Test2::Util::
1 | 1 | 1 | 3µs | 18µs | BEGIN@3 | Test2::Util::
1 | 1 | 1 | 800ns | 800ns | __ANON__ (xsub) | Test2::Util::
0 | 0 | 0 | 0s | 0s | CAN_FORK | Test2::Util::
0 | 0 | 0 | 0s | 0s | CAN_REALLY_FORK | Test2::Util::
0 | 0 | 0 | 0s | 0s | __ANON__[:138] | Test2::Util::
0 | 0 | 0 | 0s | 0s | __ANON__[:142] | Test2::Util::
0 | 0 | 0 | 0s | 0s | __ANON__[:143] | Test2::Util::
0 | 0 | 0 | 0s | 0s | __ANON__[:222] | Test2::Util::
0 | 0 | 0 | 0s | 0s | __ANON__[:235] | Test2::Util::
0 | 0 | 0 | 0s | 0s | __ANON__[:242] | Test2::Util::
0 | 0 | 0 | 0s | 0s | __ANON__[:247] | Test2::Util::
0 | 0 | 0 | 0s | 0s | _can_fork | Test2::Util::
0 | 0 | 0 | 0s | 0s | _local_try | Test2::Util::
0 | 0 | 0 | 0s | 0s | _manual_try | Test2::Util::
0 | 0 | 0 | 0s | 0s | pkg_to_file | Test2::Util::
0 | 0 | 0 | 0s | 0s | try_sig_mask | Test2::Util::
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 |