← Index
NYTProf Performance Profile   « line view »
For /usr/local/libexec/sympa/task_manager-debug.pl
  Run on Tue Jun 1 22:32:51 2021
Reported on Tue Jun 1 22:35:04 2021

Filename/usr/local/lib/perl5/site_perl/Try/Tiny.pm
StatementsExecuted 0 statements in 0s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sTry::Tiny::::BEGIN@10 Try::Tiny::BEGIN@10
0000s0sTry::Tiny::::BEGIN@13 Try::Tiny::BEGIN@13
0000s0sTry::Tiny::::BEGIN@16 Try::Tiny::BEGIN@16
0000s0sTry::Tiny::::BEGIN@2 Try::Tiny::BEGIN@2
0000s0sTry::Tiny::::BEGIN@7 Try::Tiny::BEGIN@7
0000s0sTry::Tiny::::BEGIN@8 Try::Tiny::BEGIN@8
0000s0sTry::Tiny::ScopeGuard::::BEGIN@167Try::Tiny::ScopeGuard::BEGIN@167
0000s0sTry::Tiny::ScopeGuard::::DESTROYTry::Tiny::ScopeGuard::DESTROY
0000s0sTry::Tiny::ScopeGuard::::_newTry::Tiny::ScopeGuard::_new
0000s0sTry::Tiny::::__ANON__[:28] Try::Tiny::__ANON__[:28]
0000s0sTry::Tiny::::catch Try::Tiny::catch
0000s0sTry::Tiny::::finally Try::Tiny::finally
0000s0sTry::Tiny::::try Try::Tiny::try
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1package Try::Tiny; # git description: v0.29-2-g3b23a06
2use 5.006;
3# ABSTRACT: Minimal try/catch with proper preservation of $@
4
5our $VERSION = '0.30';
6
7use strict;
8use warnings;
9
10use Exporter 5.57 'import';
11our @EXPORT = our @EXPORT_OK = qw(try catch finally);
12
13use Carp;
14$Carp::Internal{+__PACKAGE__}++;
15
16BEGIN {
17 my $su = $INC{'Sub/Util.pm'} && defined &Sub::Util::set_subname;
18 my $sn = $INC{'Sub/Name.pm'} && eval { Sub::Name->VERSION(0.08) };
19 unless ($su || $sn) {
20 $su = eval { require Sub::Util; } && defined &Sub::Util::set_subname;
21 unless ($su) {
22 $sn = eval { require Sub::Name; Sub::Name->VERSION(0.08) };
23 }
24 }
25
26 *_subname = $su ? \&Sub::Util::set_subname
27 : $sn ? \&Sub::Name::subname
28 : sub { $_[1] };
29 *_HAS_SUBNAME = ($su || $sn) ? sub(){1} : sub(){0};
30}
31
32my %_finally_guards;
33
34# Need to prototype as @ not $$ because of the way Perl evaluates the prototype.
35# Keeping it at $$ means you only ever get 1 sub because we need to eval in a list
36# context & not a scalar one
37
38sub try (&;@) {
39 my ( $try, @code_refs ) = @_;
40
41 # we need to save this here, the eval block will be in scalar context due
42 # to $failed
43 my $wantarray = wantarray;
44
45 # work around perl bug by explicitly initializing these, due to the likelyhood
46 # this will be used in global destruction (perl rt#119311)
47 my ( $catch, @finally ) = ();
48
49 # find labeled blocks in the argument list.
50 # catch and finally tag the blocks by blessing a scalar reference to them.
51 foreach my $code_ref (@code_refs) {
52
53 if ( ref($code_ref) eq 'Try::Tiny::Catch' ) {
54 croak 'A try() may not be followed by multiple catch() blocks'
55 if $catch;
56 $catch = ${$code_ref};
57 } elsif ( ref($code_ref) eq 'Try::Tiny::Finally' ) {
58 push @finally, ${$code_ref};
59 } else {
60 croak(
61 'try() encountered an unexpected argument ('
62 . ( defined $code_ref ? $code_ref : 'undef' )
63 . ') - perhaps a missing semi-colon before or'
64 );
65 }
66 }
67
68 # FIXME consider using local $SIG{__DIE__} to accumulate all errors. It's
69 # not perfect, but we could provide a list of additional errors for
70 # $catch->();
71
72 # name the blocks if we have Sub::Name installed
73 _subname(caller().'::try {...} ' => $try)
74 if _HAS_SUBNAME;
75
76 # set up scope guards to invoke the finally blocks at the end.
77 # this should really be a function scope lexical variable instead of
78 # file scope + local but that causes issues with perls < 5.20 due to
79 # perl rt#119311
80 local $_finally_guards{guards} = [
81 map { Try::Tiny::ScopeGuard->_new($_) }
82 @finally
83 ];
84
85 # save the value of $@ so we can set $@ back to it in the beginning of the eval
86 # and restore $@ after the eval finishes
87 my $prev_error = $@;
88
89 my ( @ret, $error );
90
91 # failed will be true if the eval dies, because 1 will not be returned
92 # from the eval body
93 my $failed = not eval {
94 $@ = $prev_error;
95
96 # evaluate the try block in the correct context
97 if ( $wantarray ) {
98 @ret = $try->();
99 } elsif ( defined $wantarray ) {
100 $ret[0] = $try->();
101 } else {
102 $try->();
103 };
104
105 return 1; # properly set $failed to false
106 };
107
108 # preserve the current error and reset the original value of $@
109 $error = $@;
110 $@ = $prev_error;
111
112 # at this point $failed contains a true value if the eval died, even if some
113 # destructor overwrote $@ as the eval was unwinding.
114 if ( $failed ) {
115 # pass $error to the finally blocks
116 push @$_, $error for @{$_finally_guards{guards}};
117
118 # if we got an error, invoke the catch block.
119 if ( $catch ) {
120 # This works like given($error), but is backwards compatible and
121 # sets $_ in the dynamic scope for the body of C<$catch>
122 for ($error) {
123 return $catch->($error);
124 }
125
126 # in case when() was used without an explicit return, the C<for>
127 # loop will be aborted and there's no useful return value
128 }
129
130 return;
131 } else {
132 # no failure, $@ is back to what it was, everything is fine
133 return $wantarray ? @ret : $ret[0];
134 }
135}
136
137sub catch (&;@) {
138 my ( $block, @rest ) = @_;
139
140 croak 'Useless bare catch()' unless wantarray;
141
142 _subname(caller().'::catch {...} ' => $block)
143 if _HAS_SUBNAME;
144 return (
145 bless(\$block, 'Try::Tiny::Catch'),
146 @rest,
147 );
148}
149
150sub finally (&;@) {
151 my ( $block, @rest ) = @_;
152
153 croak 'Useless bare finally()' unless wantarray;
154
155 _subname(caller().'::finally {...} ' => $block)
156 if _HAS_SUBNAME;
157 return (
158 bless(\$block, 'Try::Tiny::Finally'),
159 @rest,
160 );
161}
162
163{
164 package # hide from PAUSE
165 Try::Tiny::ScopeGuard;
166
167 use constant UNSTABLE_DOLLARAT => ("$]" < '5.013002') ? 1 : 0;
168
169 sub _new {
170 shift;
171 bless [ @_ ];
172 }
173
174 sub DESTROY {
175 my ($code, @args) = @{ $_[0] };
176
177 local $@ if UNSTABLE_DOLLARAT;
178 eval {
179 $code->(@args);
180 1;
181 } or do {
182 warn
183 "Execution of finally() block $code resulted in an exception, which "
184 . '*CAN NOT BE PROPAGATED* due to fundamental limitations of Perl. '
185 . 'Your program will continue as if this event never took place. '
186 . "Original exception text follows:\n\n"
187 . (defined $@ ? $@ : '$@ left undefined...')
188 . "\n"
189 ;
190 }
191 }
192}
193
194__PACKAGE__
195__END__