File Coverage

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

linestmtbrancondsubtimecode
1package Exception::Class::Base;
2$Exception::Class::Base::VERSION = '1.38';
3
6
6
6
6
13
4
83
use strict;
4
6
6
6
6
12
3
72
use warnings;
5
6
6
6
6
6
893
73
79
use Class::Data::Inheritable 0.02;
7
6
6
6
6
1830
62
87
use Devel::StackTrace 1.20;
8
6
6
6
6
17
6
160
use Scalar::Util qw( blessed );
9
10
6
6
6
6
13
5
405
use base qw(Class::Data::Inheritable);
11
12BEGIN {
13
6
6
19
    __PACKAGE__->mk_classdata('Trace');
14
6
9
    __PACKAGE__->mk_classdata('NoRefs');
15
6
11
    __PACKAGE__->NoRefs(1);
16
17
6
8
    __PACKAGE__->mk_classdata('NoContextInfo');
18
6
11
    __PACKAGE__->NoContextInfo(0);
19
20
6
10
    __PACKAGE__->mk_classdata('RespectOverload');
21
6
15
    __PACKAGE__->RespectOverload(0);
22
23
6
7
    __PACKAGE__->mk_classdata('MaxArgLength');
24
6
8
    __PACKAGE__->MaxArgLength(0);
25
26
0
0
    sub Fields { () }
27}
28
29use overload
30
31    # an exception is always true
32
6
6
6
0
6
0
17
4
353
0
    bool => sub { 1 }, '""' => 'as_string', fallback => 1;
33
34# Create accessor routines
35BEGIN {
36
6
6
8
    my @fields = qw( message pid uid euid gid egid time trace );
37
38
6
5
    foreach my $f (@fields) {
39
48
0
0
0
48
0
0
        my $sub = sub { my $s = shift; return $s->{$f}; };
40
41
6
6
6
6
15
4
419
        no strict 'refs';
42
48
48
63
71
        *{$f} = $sub;
43    }
44
6
6
    *error = \&message;
45
46
6
14
    my %trace_fields = (
47        package => 'package',
48        file    => 'filename',
49        line    => 'line',
50    );
51
52
6
26
    while ( my ( $f, $m ) = each %trace_fields ) {
53        my $sub = sub {
54
0
0
0
            my $s = shift;
55
0
0
0
            return $s->{$f} if exists $s->{$f};
56
57
0
0
            my $frame = $s->trace->frame(0);
58
59
0
0
0
            return $s->{$f} = $frame ? $frame->$m() : undef;
60
18
32
        };
61
6
6
6
6
14
3
106
        no strict 'refs';
62
18
18
10
2506
        *{$f} = $sub;
63    }
64}
65
66
0
0
sub Classes { Exception::Class::Classes() }
67
68sub throw {
69
0
0
    my $proto = shift;
70
71
0
0
    $proto->rethrow if ref $proto;
72
73
0
    die $proto->new(@_);
74}
75
76sub rethrow {
77
0
0
    my $self = shift;
78
79
0
    die $self;
80}
81
82sub new {
83
0
0
    my $proto = shift;
84
0
0
    my $class = ref $proto || $proto;
85
86
0
    my $self = bless {}, $class;
87
88
0
    $self->_initialize(@_);
89
90
0
    return $self;
91}
92
93sub _initialize {
94
0
0
    my $self = shift;
95
0
0
    my %p = @_ == 1 ? ( error => $_[0] ) : @_;
96
97
0
0
    $self->{message} = $p{message} || $p{error} || '';
98
99
0
0
    $self->{show_trace} = $p{show_trace} if exists $p{show_trace};
100
101
0
0
    if ( $self->NoContextInfo() ) {
102
0
        $self->{show_trace} = 0;
103
0
        $self->{package} = $self->{file} = $self->{line} = undef;
104    }
105    else {
106        # CORE::time is important to fix an error with some versions of
107        # Perl
108
0
        $self->{time} = CORE::time();
109
0
        $self->{pid}  = $$;
110
0
        $self->{uid}  = $<;
111
0
        $self->{euid} = $>;
112
0
        $self->{gid}  = $(;
113
0
        $self->{egid} = $);
114
115
0
        my @ignore_class   = (__PACKAGE__);
116
0
        my @ignore_package = 'Exception::Class';
117
118
0
0
        if ( my $i = delete $p{ignore_class} ) {
119
0
0
            push @ignore_class, ( ref($i) eq 'ARRAY' ? @$i : $i );
120        }
121
122
0
0
        if ( my $i = delete $p{ignore_package} ) {
123
0
0
            push @ignore_package, ( ref($i) eq 'ARRAY' ? @$i : $i );
124        }
125
126
0
        $self->{trace} = Devel::StackTrace->new(
127            ignore_class     => \@ignore_class,
128            ignore_package   => \@ignore_package,
129            no_refs          => $self->NoRefs,
130            respect_overload => $self->RespectOverload,
131            max_arg_length   => $self->MaxArgLength,
132        );
133    }
134
135
0
0
    my %fields = map { $_ => 1 } $self->Fields;
136
0
    while ( my ( $key, $value ) = each %p ) {
137
0
0
        next if $key =~ /^(?:error|message|show_trace)$/;
138
139
0
0
        if ( $fields{$key} ) {
140
0
            $self->{$key} = $value;
141        }
142        else {
143
0
            Exception::Class::Base->throw(
144                error => "unknown field $key passed to constructor for class "
145                    . ref $self );
146        }
147    }
148}
149
150sub context_hash {
151
0
0
    my $self = shift;
152
153    return {
154
0
        time => $self->{time},
155        pid  => $self->{pid},
156        uid  => $self->{uid},
157        euid => $self->{euid},
158        gid  => $self->{gid},
159        egid => $self->{egid},
160    };
161}
162
163sub field_hash {
164
0
0
    my $self = shift;
165
166
0
    my $hash = {};
167
168
0
    for my $field ( $self->Fields ) {
169
0
        $hash->{$field} = $self->$field;
170    }
171
172
0
    return $hash;
173}
174
175sub description {
176
0
0
    return 'Generic exception';
177}
178
179sub show_trace {
180
0
0
    my $self = shift;
181
182
0
0
    return 0 unless $self->{trace};
183
184
0
0
    if (@_) {
185
0
        $self->{show_trace} = shift;
186    }
187
188
0
0
    return exists $self->{show_trace} ? $self->{show_trace} : $self->Trace;
189}
190
191sub as_string {
192
0
0
    my $self = shift;
193
194
0
    my $str = $self->full_message;
195
0
0
0
    unless ( defined $str && length $str ) {
196
0
        my $desc = $self->description;
197
0
0
0
        $str = defined $desc
198            && length $desc ? "[$desc]" : "[Generic exception]";
199    }
200
201
0
0
    $str .= "\n\n" . $self->trace->as_string
202        if $self->show_trace;
203
204
0
    return $str;
205}
206
207
0
0
sub full_message { $_[0]->{message} }
208
209#
210# The %seen bit protects against circular inheritance.
211#
212eval <<'EOF' if $] == 5.006;
213sub isa {
214    my ( $inheritor, $base ) = @_;
215    $inheritor = ref($inheritor) if ref($inheritor);
216
217    my %seen;
218
219    no strict 'refs';
220    my @parents = ( $inheritor, @{"$inheritor\::ISA"} );
221    while ( my $class = shift @parents ) {
222        return 1 if $class eq $base;
223
224        push @parents, grep { !$seen{$_}++ } @{"$class\::ISA"};
225    }
226    return 0;
227}
228EOF
229
230sub caught {
231
0
0
    my $class = shift;
232
233
0
    my $e = $@;
234
235
0
0
0
    return unless defined $e && blessed($e) && $e->isa($class);
236
0
    return $e;
237}
238
2391;
240
241# ABSTRACT: A base class for exception objects
242