← 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.pm
StatementsExecuted 0 statements in 0s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sException::Class::::BEGIN@10Exception::Class::BEGIN@10
0000s0sException::Class::::BEGIN@11Exception::Class::BEGIN@11
0000s0sException::Class::::BEGIN@12Exception::Class::BEGIN@12
0000s0sException::Class::::BEGIN@15Exception::Class::BEGIN@15
0000s0sException::Class::::BEGIN@178Exception::Class::BEGIN@178
0000s0sException::Class::::BEGIN@187Exception::Class::BEGIN@187
0000s0sException::Class::::BEGIN@3Exception::Class::BEGIN@3
0000s0sException::Class::::BEGIN@49Exception::Class::BEGIN@49
0000s0sException::Class::::BEGIN@5Exception::Class::BEGIN@5
0000s0sException::Class::::BEGIN@6Exception::Class::BEGIN@6
0000s0sException::Class::::BEGIN@83Exception::Class::BEGIN@83
0000s0sException::Class::::CORE:matchException::Class::CORE:match (opcode)
0000s0sException::Class::::CORE:sortException::Class::CORE:sort (opcode)
0000s0sException::Class::::CORE:substException::Class::CORE:subst (opcode)
0000s0sException::Class::::ClassesException::Class::Classes
0000s0sException::Class::::__ANON__Exception::Class::__ANON__ (xsub)
0000s0sException::Class::::__ANON__[:180]Exception::Class::__ANON__[:180]
0000s0sException::Class::::_make_parentsException::Class::_make_parents
0000s0sException::Class::::_make_subclassException::Class::_make_subclass
0000s0sException::Class::::caughtException::Class::caught
0000s0sException::Class::::importException::Class::import
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;
2
3use 5.008001;
4
5use strict;
6use warnings;
7
8our $VERSION = '1.45';
9
10use Carp qw( croak );
11use Exception::Class::Base;
12use Scalar::Util qw( blessed reftype );
13
14our $BASE_EXC_CLASS;
15BEGIN { $BASE_EXC_CLASS ||= 'Exception::Class::Base'; }
16
17our %CLASSES;
18
19sub import {
20 my $class = shift;
21
22 ## no critic (Variables::ProhibitPackageVars)
23 local $Exception::Class::Caller = caller();
24
25 my %c;
26
27 my %needs_parent;
28 while ( my $subclass = shift ) {
29 my $def = ref $_[0] ? shift : {};
30 $def->{isa}
31 = $def->{isa}
32 ? ( ref $def->{isa} ? $def->{isa} : [ $def->{isa} ] )
33 : [];
34
35 $c{$subclass} = $def;
36 }
37
38 # We need to sort by length because if we check for keys in the
39 # Foo::Bar:: stash, this creates a "Bar::" key in the Foo:: stash!
40MAKE_CLASSES:
41 foreach my $subclass ( sort { length $a <=> length $b } keys %c ) {
42 my $def = $c{$subclass};
43
44 # We already made this one.
45 next if $CLASSES{$subclass};
46
47 {
48 ## no critic (TestingAndDebugging::ProhibitNoStrict)
49 no strict 'refs';
50 foreach my $parent ( @{ $def->{isa} } ) {
51 unless ( keys %{"$parent\::"} ) {
52 $needs_parent{$subclass} = {
53 parents => $def->{isa},
54 def => $def
55 };
56 next MAKE_CLASSES;
57 }
58 }
59 }
60
61 $class->_make_subclass(
62 subclass => $subclass,
63 def => $def || {},
64 );
65 }
66
67 foreach my $subclass ( keys %needs_parent ) {
68
69 # This will be used to spot circular references.
70 my %seen;
71 $class->_make_parents( \%needs_parent, $subclass, \%seen );
72 }
73}
74
75sub _make_parents {
76 my $class = shift;
77 my $needs = shift;
78 my $subclass = shift;
79 my $seen = shift;
80 my $child = shift; # Just for error messages.
81
82 ## no critic (TestingAndDebugging::ProhibitNoStrict, TestingAndDebugging::ProhibitProlongedStrictureOverride)
83 no strict 'refs';
84
85 # What if someone makes a typo in specifying their 'isa' param?
86 # This should catch it. Either it's been made because it didn't
87 # have missing parents OR it's in our hash as needing a parent.
88 # If neither of these is true then the _only_ place it is
89 # mentioned is in the 'isa' param for some other class, which is
90 # not a good enough reason to make a new class.
91 die
92 "Class $subclass appears to be a typo as it is only specified in the 'isa' param for $child\n"
93 unless exists $needs->{$subclass}
94 || $CLASSES{$subclass}
95 || keys %{"$subclass\::"};
96
97 foreach my $c ( @{ $needs->{$subclass}{parents} } ) {
98
99 # It's been made
100 next if $CLASSES{$c} || keys %{"$c\::"};
101
102 die "There appears to be some circularity involving $subclass\n"
103 if $seen->{$subclass};
104
105 $seen->{$subclass} = 1;
106
107 $class->_make_parents( $needs, $c, $seen, $subclass );
108 }
109
110 return if $CLASSES{$subclass} || keys %{"$subclass\::"};
111
112 $class->_make_subclass(
113 subclass => $subclass,
114 def => $needs->{$subclass}{def}
115 );
116}
117
118sub _make_subclass {
119 my $class = shift;
120 my %p = @_;
121
122 my $subclass = $p{subclass};
123 my $def = $p{def};
124
125 my $isa;
126 if ( $def->{isa} ) {
127 $isa = ref $def->{isa} ? join q{ }, @{ $def->{isa} } : $def->{isa};
128 }
129 $isa ||= $BASE_EXC_CLASS;
130
131 my $version_name = 'VERSION';
132
133 my $code = <<"EOPERL";
134package $subclass;
135
136use base qw($isa);
137
138our \$$version_name = '1.1';
139
1401;
141
142EOPERL
143
144 if ( $def->{description} ) {
145 ( my $desc = $def->{description} ) =~ s/([\\\'])/\\$1/g;
146 $code .= <<"EOPERL";
147sub description
148{
149 return '$desc';
150}
151EOPERL
152 }
153
154 my @fields;
155 if ( my $fields = $def->{fields} ) {
156 @fields
157 = ref $fields && reftype $fields eq 'ARRAY' ? @$fields : $fields;
158
159 $code
160 .= 'sub Fields { return ($_[0]->SUPER::Fields, '
161 . join( ', ', map {"'$_'"} @fields )
162 . ") }\n\n";
163
164 foreach my $field (@fields) {
165 croak
166 "Invalid field name <$field>. A field name must be a legal Perl identifier."
167 unless $field =~ /\A[a-z_][a-z0-9_]*\z/i;
168 $code .= sprintf( "sub %s { \$_[0]->{%s} }\n", $field, $field );
169 }
170 }
171
172 if ( my $alias = $def->{alias} ) {
173 ## no critic (Variables::ProhibitPackageVars)
174 die 'Cannot make alias without caller'
175 unless defined $Exception::Class::Caller;
176
177 ## no critic (TestingAndDebugging::ProhibitNoStrict)
178 no strict 'refs';
179 *{"$Exception::Class::Caller\::$alias"}
180 = sub { $subclass->throw(@_) };
181 }
182
183 if ( my $defaults = $def->{defaults} ) {
184 $code
185 .= "sub _defaults { return shift->SUPER::_defaults, our \%_DEFAULTS }\n";
186 ## no critic (TestingAndDebugging::ProhibitNoStrict)
187 no strict 'refs';
188 *{"$subclass\::_DEFAULTS"} = {%$defaults};
189 }
190
191 ## no critic (BuiltinFunctions::ProhibitStringyEval, ErrorHandling::RequireCheckingReturnValueOfEval)
192 eval $code;
# spent 0s executing statements in string eval # spent 0s executing statements in string eval # spent 0s executing statements in string eval # spent 0s executing statements in string eval # spent 0s executing statements in string eval # spent 0s executing statements in string eval
193 die $@ if $@;
194
195 ( my $filename = "$subclass.pm" ) =~ s{::}{/}g;
196 $INC{$filename} = __FILE__;
197
198 $CLASSES{$subclass} = 1;
199}
200
201sub caught {
202 my $e = $@;
203
204 return $e unless $_[1];
205
206 return unless blessed($e) && $e->isa( $_[1] );
207 return $e;
208}
209
210sub Classes { sort keys %Exception::Class::CLASSES }
211
2121;
213
214# ABSTRACT: A module that allows you to declare real exception classes in Perl
215
216__END__