File Coverage

File:local/lib/perl5/Exception/Class.pm
Coverage:50.0%

linestmtbrancondsubtimecode
1package Exception::Class;
2$Exception::Class::VERSION = '1.38';
3
6
6
6
67
9
use 5.008001;
4
5
6
6
6
6
11
4
66
use strict;
6
7
6
6
6
6
1092
7
80
use Exception::Class::Base;
8
6
6
6
6
17
4
193
use Scalar::Util qw(blessed);
9
10our $BASE_EXC_CLASS;
11
6
50
6
408
BEGIN { $BASE_EXC_CLASS ||= 'Exception::Class::Base'; }
12
13our %CLASSES;
14
15sub import {
16
6
6
5
    my $class = shift;
17
18
6
7
    local $Exception::Class::Caller = caller();
19
20
6
4
    my %c;
21
22    my %needs_parent;
23
6
13
    while ( my $subclass = shift ) {
24
6
50
12
        my $def = ref $_[0] ? shift : {};
25
6
0
50
12
        $def->{isa}
26            = $def->{isa}
27            ? ( ref $def->{isa} ? $def->{isa} : [ $def->{isa} ] )
28            : [];
29
30
6
14
        $c{$subclass} = $def;
31    }
32
33    # We need to sort by length because if we check for keys in the
34    # Foo::Bar:: stash, this creates a "Bar::" key in the Foo:: stash!
35MAKE_CLASSES:
36
6
0
17
0
    foreach my $subclass ( sort { length $a <=> length $b } keys %c ) {
37
6
5
        my $def = $c{$subclass};
38
39        # We already made this one.
40
6
50
11
        next if $CLASSES{$subclass};
41
42        {
43
6
6
6
6
6
13
3
532
5
            no strict 'refs';
44
6
6
6
8
            foreach my $parent ( @{ $def->{isa} } ) {
45
0
0
0
0
0
                unless ( keys %{"$parent\::"} ) {
46
0
0
                    $needs_parent{$subclass} = {
47                        parents => $def->{isa},
48                        def     => $def
49                    };
50
0
0
                    next MAKE_CLASSES;
51                }
52            }
53        }
54
55        $class->_make_subclass(
56
6
50
21
            subclass => $subclass,
57            def      => $def || {},
58        );
59    }
60
61
6
109
    foreach my $subclass ( keys %needs_parent ) {
62
63        # This will be used to spot circular references.
64
0
0
        my %seen;
65
0
0
        $class->_make_parents( \%needs_parent, $subclass, \%seen );
66    }
67}
68
69sub _make_parents {
70
0
0
0
    my $class    = shift;
71
0
0
    my $needs    = shift;
72
0
0
    my $subclass = shift;
73
0
0
    my $seen     = shift;
74
0
0
    my $child    = shift;    # Just for error messages.
75
76
6
6
6
6
16
3
1246
    no strict 'refs';
77
78    # What if someone makes a typo in specifying their 'isa' param?
79    # This should catch it.  Either it's been made because it didn't
80    # have missing parents OR it's in our hash as needing a parent.
81    # If neither of these is true then the _only_ place it is
82    # mentioned is in the 'isa' param for some other class, which is
83    # not a good enough reason to make a new class.
84
0
0
    die
85        "Class $subclass appears to be a typo as it is only specified in the 'isa' param for $child\n"
86        unless exists $needs->{$subclass}
87        || $CLASSES{$subclass}
88
0
0
0
0
        || keys %{"$subclass\::"};
89
90
0
0
0
0
    foreach my $c ( @{ $needs->{$subclass}{parents} } ) {
91
92        # It's been made
93
0
0
0
0
0
0
        next if $CLASSES{$c} || keys %{"$c\::"};
94
95
0
0
0
        die "There appears to be some circularity involving $subclass\n"
96            if $seen->{$subclass};
97
98
0
0
        $seen->{$subclass} = 1;
99
100
0
0
        $class->_make_parents( $needs, $c, $seen, $subclass );
101    }
102
103
0
0
0
0
0
0
    return if $CLASSES{$subclass} || keys %{"$subclass\::"};
104
105
0
0
    $class->_make_subclass(
106        subclass => $subclass,
107        def      => $needs->{$subclass}{def}
108    );
109}
110
111sub _make_subclass {
112
6
6
12
    my $class = shift;
113
6
9
    my %p     = @_;
114
115
6
5
    my $subclass = $p{subclass};
116
6
4
    my $def      = $p{def};
117
118
6
5
    my $isa;
119
6
50
7
    if ( $def->{isa} ) {
120
6
6
50
10
8
        $isa = ref $def->{isa} ? join ' ', @{ $def->{isa} } : $def->{isa};
121    }
122
6
33
17
    $isa ||= $BASE_EXC_CLASS;
123
124
6
3
    my $version_name = 'VERSION';
125
126
6
11
    my $code = <<"EOPERL";
127package $subclass;
128
129use base qw($isa);
130
131our \$$version_name = '1.1';
132
1331;
134
135EOPERL
136
137
6
50
10
    if ( $def->{description} ) {
138
6
7
        ( my $desc = $def->{description} ) =~ s/([\\\'])/\\$1/g;
139
6
9
        $code .= <<"EOPERL";
140sub description
141{
142    return '$desc';
143}
144EOPERL
145    }
146
147
6
3
    my @fields;
148
6
50
13
    if ( my $fields = $def->{fields} ) {
149
0
0
0
        @fields = UNIVERSAL::isa( $fields, 'ARRAY' ) ? @$fields : $fields;
150
151
0
0
        $code
152            .= "sub Fields { return (\$_[0]->SUPER::Fields, "
153
0
0
            . join( ", ", map { "'$_'" } @fields )
154            . ") }\n\n";
155
156
0
0
        foreach my $field (@fields) {
157
0
0
            $code .= sprintf( "sub %s { \$_[0]->{%s} }\n", $field, $field );
158        }
159    }
160
161
6
50
10
    if ( my $alias = $def->{alias} ) {
162
6
50
6
        die "Cannot make alias without caller"
163            unless defined $Exception::Class::Caller;
164
165
6
6
6
6
16
5
277
        no strict 'refs';
166
6
16
        *{"$Exception::Class::Caller\::$alias"}
167
6
0
0
10
0
            = sub { $subclass->throw(@_) };
168    }
169
170
6
50
8
    if ( my $defaults = $def->{defaults} ) {
171
0
0
        $code
172            .= "sub _defaults { return shift->SUPER::_defaults, our \%_DEFAULTS }\n";
173
6
6
6
6
13
5
485
        no strict 'refs';
174
0
0
0
0
        *{"$subclass\::_DEFAULTS"} = {%$defaults};
175    }
176
177
6
6
6
6
0
6
0
13
4
282
192
    eval $code;
178
179
6
50
12
    die $@ if $@;
180
181
6
17
    $CLASSES{$subclass} = 1;
182}
183
184sub caught {
185
0
0
    my $e = $@;
186
187
0
0
    return $e unless $_[1];
188
189
0
0
0
    return unless blessed($e) && $e->isa( $_[1] );
190
0
    return $e;
191}
192
193
0
0
sub Classes { sort keys %Exception::Class::CLASSES }
194
1951;
196
197# ABSTRACT: A module that allows you to declare real exception classes in Perl
198