Filename | /usr/local/lib/perl5/site_perl/Exception/Class.pm |
Statements | Executed 0 statements in 0s |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
0 | 0 | 0 | 0s | 0s | BEGIN@10 | Exception::Class::
0 | 0 | 0 | 0s | 0s | BEGIN@11 | Exception::Class::
0 | 0 | 0 | 0s | 0s | BEGIN@12 | Exception::Class::
0 | 0 | 0 | 0s | 0s | BEGIN@15 | Exception::Class::
0 | 0 | 0 | 0s | 0s | BEGIN@178 | Exception::Class::
0 | 0 | 0 | 0s | 0s | BEGIN@187 | Exception::Class::
0 | 0 | 0 | 0s | 0s | BEGIN@3 | Exception::Class::
0 | 0 | 0 | 0s | 0s | BEGIN@49 | Exception::Class::
0 | 0 | 0 | 0s | 0s | BEGIN@5 | Exception::Class::
0 | 0 | 0 | 0s | 0s | BEGIN@6 | Exception::Class::
0 | 0 | 0 | 0s | 0s | BEGIN@83 | Exception::Class::
0 | 0 | 0 | 0s | 0s | CORE:match (opcode) | Exception::Class::
0 | 0 | 0 | 0s | 0s | CORE:sort (opcode) | Exception::Class::
0 | 0 | 0 | 0s | 0s | CORE:subst (opcode) | Exception::Class::
0 | 0 | 0 | 0s | 0s | Classes | Exception::Class::
0 | 0 | 0 | 0s | 0s | __ANON__ (xsub) | Exception::Class::
0 | 0 | 0 | 0s | 0s | __ANON__[:180] | Exception::Class::
0 | 0 | 0 | 0s | 0s | _make_parents | Exception::Class::
0 | 0 | 0 | 0s | 0s | _make_subclass | Exception::Class::
0 | 0 | 0 | 0s | 0s | caught | Exception::Class::
0 | 0 | 0 | 0s | 0s | import | Exception::Class::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | package Exception::Class; | ||||
2 | |||||
3 | use 5.008001; | ||||
4 | |||||
5 | use strict; | ||||
6 | use warnings; | ||||
7 | |||||
8 | our $VERSION = '1.45'; | ||||
9 | |||||
10 | use Carp qw( croak ); | ||||
11 | use Exception::Class::Base; | ||||
12 | use Scalar::Util qw( blessed reftype ); | ||||
13 | |||||
14 | our $BASE_EXC_CLASS; | ||||
15 | BEGIN { $BASE_EXC_CLASS ||= 'Exception::Class::Base'; } | ||||
16 | |||||
17 | our %CLASSES; | ||||
18 | |||||
19 | sub 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! | ||||
40 | MAKE_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 | |||||
75 | sub _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 | |||||
118 | sub _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"; | ||||
134 | package $subclass; | ||||
135 | |||||
136 | use base qw($isa); | ||||
137 | |||||
138 | our \$$version_name = '1.1'; | ||||
139 | |||||
140 | 1; | ||||
141 | |||||
142 | EOPERL | ||||
143 | |||||
144 | if ( $def->{description} ) { | ||||
145 | ( my $desc = $def->{description} ) =~ s/([\\\'])/\\$1/g; | ||||
146 | $code .= <<"EOPERL"; | ||||
147 | sub description | ||||
148 | { | ||||
149 | return '$desc'; | ||||
150 | } | ||||
151 | EOPERL | ||||
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 | |||||
201 | sub caught { | ||||
202 | my $e = $@; | ||||
203 | |||||
204 | return $e unless $_[1]; | ||||
205 | |||||
206 | return unless blessed($e) && $e->isa( $_[1] ); | ||||
207 | return $e; | ||||
208 | } | ||||
209 | |||||
210 | sub Classes { sort keys %Exception::Class::CLASSES } | ||||
211 | |||||
212 | 1; | ||||
213 | |||||
214 | # ABSTRACT: A module that allows you to declare real exception classes in Perl | ||||
215 | |||||
216 | __END__ |