← 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:06 2021

Filename/usr/local/lib/perl5/site_perl/Exception/Class/Base.pm
StatementsExecuted 0 statements in 0s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sException::Class::Base::::BEGIN@10Exception::Class::Base::BEGIN@10
0000s0sException::Class::Base::::BEGIN@12Exception::Class::Base::BEGIN@12
0000s0sException::Class::Base::::BEGIN@14Exception::Class::Base::BEGIN@14
0000s0sException::Class::Base::::BEGIN@3Exception::Class::Base::BEGIN@3
0000s0sException::Class::Base::::BEGIN@4Exception::Class::Base::BEGIN@4
0000s0sException::Class::Base::::BEGIN@44Exception::Class::Base::BEGIN@44
0000s0sException::Class::Base::::BEGIN@47Exception::Class::Base::BEGIN@47
0000s0sException::Class::Base::::BEGIN@54Exception::Class::Base::BEGIN@54
0000s0sException::Class::Base::::BEGIN@76Exception::Class::Base::BEGIN@76
0000s0sException::Class::Base::::BEGIN@8Exception::Class::Base::BEGIN@8
0000s0sException::Class::Base::::BEGIN@9Exception::Class::Base::BEGIN@9
0000s0sException::Class::Base::::ClassesException::Class::Base::Classes
0000s0sException::Class::Base::::FieldsException::Class::Base::Fields
0000s0sException::Class::Base::::NoRefsException::Class::Base::NoRefs
0000s0sException::Class::Base::::__ANON__Exception::Class::Base::__ANON__ (xsub)
0000s0sException::Class::Base::::__ANON__[:44]Exception::Class::Base::__ANON__[:44]
0000s0sException::Class::Base::::__ANON__[:51]Exception::Class::Base::__ANON__[:51]
0000s0sException::Class::Base::::__ANON__[:73]Exception::Class::Base::__ANON__[:73]
0000s0sException::Class::Base::::_initializeException::Class::Base::_initialize
0000s0sException::Class::Base::::as_stringException::Class::Base::as_string
0000s0sException::Class::Base::::caughtException::Class::Base::caught
0000s0sException::Class::Base::::context_hashException::Class::Base::context_hash
0000s0sException::Class::Base::::descriptionException::Class::Base::description
0000s0sException::Class::Base::::field_hashException::Class::Base::field_hash
0000s0sException::Class::Base::::full_messageException::Class::Base::full_message
0000s0sException::Class::Base::::newException::Class::Base::new
0000s0sException::Class::Base::::rethrowException::Class::Base::rethrow
0000s0sException::Class::Base::::show_traceException::Class::Base::show_trace
0000s0sException::Class::Base::::throwException::Class::Base::throw
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1package Exception::Class::Base;
2
3use strict;
4use warnings;
5
6our $VERSION = '1.45';
7
8use Class::Data::Inheritable 0.02;
9use Devel::StackTrace 2.00;
10use Scalar::Util qw( blessed );
11
12use base qw(Class::Data::Inheritable);
13
14BEGIN {
15 __PACKAGE__->mk_classdata('Trace');
16 __PACKAGE__->mk_classdata('UnsafeRefCapture');
17
18 __PACKAGE__->mk_classdata('NoContextInfo');
19 __PACKAGE__->NoContextInfo(0);
20
21 __PACKAGE__->mk_classdata('RespectOverload');
22 __PACKAGE__->RespectOverload(0);
23
24 __PACKAGE__->mk_classdata('MaxArgLength');
25 __PACKAGE__->MaxArgLength(0);
26
27 sub NoRefs {
28 my $self = shift;
29 if (@_) {
30 my $val = shift;
31 return $self->UnsafeRefCapture( !$val );
32 }
33 else {
34 return $self->UnsafeRefCapture;
35 }
36 }
37
38 sub Fields { () }
39}
40
41use overload
42
43 # an exception is always true
44 bool => sub {1}, '""' => 'as_string', fallback => 1;
45
46# Create accessor routines
47BEGIN {
48 my @fields = qw( message pid uid euid gid egid time trace );
49
50 foreach my $f (@fields) {
51 my $sub = sub { my $s = shift; return $s->{$f}; };
52
53 ## no critic (TestingAndDebugging::ProhibitNoStrict)
54 no strict 'refs';
55 *{$f} = $sub;
56 }
57 *error = \&message;
58
59 my %trace_fields = (
60 package => 'package',
61 file => 'filename',
62 line => 'line',
63 );
64
65 while ( my ( $f, $m ) = each %trace_fields ) {
66 my $sub = sub {
67 my $s = shift;
68 return $s->{$f} if exists $s->{$f};
69
70 my $frame = $s->trace->frame(0);
71
72 return $s->{$f} = $frame ? $frame->$m : undef;
73 };
74
75 ## no critic (TestingAndDebugging::ProhibitNoStrict)
76 no strict 'refs';
77 *{$f} = $sub;
78 }
79}
80
81sub Classes { Exception::Class::Classes() }
82
83sub throw {
84 my $proto = shift;
85
86 $proto->rethrow if ref $proto;
87
88 die $proto->new(@_);
89}
90
91sub rethrow {
92 my $self = shift;
93
94 die $self;
95}
96
97sub new {
98 my $proto = shift;
99 my $class = ref $proto || $proto;
100
101 my $self = bless {}, $class;
102
103 $self->_initialize(@_);
104
105 return $self;
106}
107
108sub _initialize {
109 my $self = shift;
110 my %p = @_ == 1 ? ( error => $_[0] ) : @_;
111
112 $self->{message} = $p{message} || $p{error} || q{};
113
114 $self->{show_trace} = $p{show_trace} if exists $p{show_trace};
115
116 if ( $self->NoContextInfo ) {
117 $self->{show_trace} = 0;
118 $self->{package} = $self->{file} = $self->{line} = undef;
119 }
120 else {
121 # CORE::time is important to fix an error with some versions of
122 # Perl
123 $self->{time} = CORE::time();
124 $self->{pid} = $$;
125 $self->{uid} = $<;
126 $self->{euid} = $>;
127 $self->{gid} = $(;
128 $self->{egid} = $);
129
130 my @ignore_class = (__PACKAGE__);
131 my @ignore_package = 'Exception::Class';
132
133 if ( my $i = delete $p{ignore_class} ) {
134 push @ignore_class, ( ref($i) eq 'ARRAY' ? @$i : $i );
135 }
136
137 if ( my $i = delete $p{ignore_package} ) {
138 push @ignore_package, ( ref($i) eq 'ARRAY' ? @$i : $i );
139 }
140
141 $self->{trace} = Devel::StackTrace->new(
142 ignore_class => \@ignore_class,
143 ignore_package => \@ignore_package,
144 unsafe_ref_capture => $self->UnsafeRefCapture,
145 respect_overload => $self->RespectOverload,
146 max_arg_length => $self->MaxArgLength,
147 map { $p{$_} ? ( $_ => delete $p{$_} ) : () } qw(
148 frame_filter
149 filter_frames_early
150 skip_frames
151 ),
152 );
153 }
154
155 my %fields = map { $_ => 1 } $self->Fields;
156 while ( my ( $key, $value ) = each %p ) {
157 next if $key =~ /^(?:error|message|show_trace)$/;
158
159 if ( $fields{$key} ) {
160 $self->{$key} = $value;
161 }
162 else {
163 Exception::Class::Base->throw(
164 error => "unknown field $key passed to constructor for class "
165 . ref $self );
166 }
167 }
168}
169
170sub context_hash {
171 my $self = shift;
172
173 return {
174 time => $self->{time},
175 pid => $self->{pid},
176 uid => $self->{uid},
177 euid => $self->{euid},
178 gid => $self->{gid},
179 egid => $self->{egid},
180 };
181}
182
183sub field_hash {
184 my $self = shift;
185
186 my $hash = {};
187
188 for my $field ( $self->Fields ) {
189 $hash->{$field} = $self->$field;
190 }
191
192 return $hash;
193}
194
195sub description {
196 return 'Generic exception';
197}
198
199sub show_trace {
200 my $self = shift;
201
202 return 0 unless $self->{trace};
203
204 if (@_) {
205 $self->{show_trace} = shift;
206 }
207
208 return exists $self->{show_trace} ? $self->{show_trace} : $self->Trace;
209}
210
211sub as_string {
212 my $self = shift;
213
214 my $str = $self->full_message;
215 unless ( defined $str && length $str ) {
216 my $desc = $self->description;
217 $str = defined $desc
218 && length $desc ? "[$desc]" : '[Generic exception]';
219 }
220
221 $str .= "\n\n" . $self->trace->as_string
222 if $self->show_trace;
223
224 return $str;
225}
226
227sub full_message { $_[0]->message }
228
229#
230# The %seen bit protects against circular inheritance.
231#
232## no critic (BuiltinFunctions::ProhibitStringyEval, ErrorHandling::RequireCheckingReturnValueOfEval)
233eval <<'EOF' if $] == 5.006;
234sub isa {
235 my ( $inheritor, $base ) = @_;
236 $inheritor = ref($inheritor) if ref($inheritor);
237
238 my %seen;
239
240 no strict 'refs';
241 my @parents = ( $inheritor, @{"$inheritor\::ISA"} );
242 while ( my $class = shift @parents ) {
243 return 1 if $class eq $base;
244
245 push @parents, grep { !$seen{$_}++ } @{"$class\::ISA"};
246 }
247 return 0;
248}
249EOF
250
251sub caught {
252 my $class = shift;
253
254 my $e = $@;
255
256 return unless defined $e && blessed($e) && $e->isa($class);
257 return $e;
258}
259
2601;
261
262# ABSTRACT: A base class for exception objects
263
264__END__