File Coverage

lib/Pcore/Core/Exception/Object.pm
Criterion Covered Total %
statement 13 44 29.5
branch 0 8 0.0
condition 0 3 0.0
subroutine 5 12 41.6
pod 0 2 0.0
total 18 69 26.0


line stmt bran cond sub pod time code
1             package Pcore::Core::Exception::Object;
2              
3 5     5   31 use Pcore -class;
  5         10  
  5         30  
4 5     5   36 use Pcore::Util::Scalar qw[blessed];
  5         10  
  5         38  
5 5     5   1918 use Time::HiRes qw[];
  5         4802  
  5         593  
6              
7             use overload #
8             q[""] => sub {
9              
10             # string overloading can happens only from perl internals calls, such as eval in "use" or "require" (or other compilation errors), or not handled "die", so we don't need full trace here
11 0     0   0 return $_[0]->{msg} . $LF;
12             },
13             q[0+] => sub {
14 0     0   0 return $_[0]->exit_code;
15             },
16             bool => sub {
17 8     8   34 return 1;
18             },
19 5     5   33 fallback => undef;
  5         9  
  5         54  
20              
21             has msg => ( is => 'ro', isa => Str, required => 1 );
22             has level => ( is => 'ro', isa => Enum [qw[ERROR WARN]], required => 1 );
23             has call_stack => ( is => 'ro', isa => Maybe [ScalarRef], required => 1 );
24             has timestamp => ( is => 'ro', isa => Num, required => 1 );
25              
26             has exit_code => ( is => 'lazy', isa => Int );
27             has with_trace => ( is => 'ro', isa => Bool, default => 1 );
28             has is_ae_cb_error => ( is => 'ro', isa => Bool, required => 1 );
29              
30             has longmess => ( is => 'lazy', isa => Str, init_arg => undef );
31             has to_string => ( is => 'lazy', isa => Str, init_arg => undef );
32              
33             has is_logged => ( is => 'ro', isa => Bool, default => 0, init_arg => undef );
34              
35             around new => sub ( $orig, $self, $msg, %args ) {
36             $args{skip_frames} //= 0;
37              
38             if ( my $blessed = blessed $msg ) {
39              
40             # already cought
41             if ( $blessed eq __PACKAGE__ ) {
42             return $msg;
43             }
44              
45             # catch TypeTiny exceptions
46             elsif ( $blessed eq 'Error::TypeTiny::Assertion' ) {
47             $msg = $msg->message;
48              
49             # skip frames: Error::TypeTiny::throw
50             $args{skip_frames} += 1;
51             }
52              
53             # catch Moose exceptions
54             elsif ( $blessed =~ /\AMoose::Exception/sm ) {
55             $msg = $msg->message;
56             }
57              
58             # other foreign exception objects are returned as-is
59             # else {
60             # return;
61             # }
62             }
63              
64             # cut trailing "\n" from $msg
65             {
66             local $/ = q[];
67              
68             chomp $msg;
69             };
70              
71             \my $is_ae_cb_error = \$args{is_ae_cb_error};
72              
73             my $x = $args{skip_frames} + 3;
74              
75             my @frames;
76              
77             while ( my @frame = caller $x++ ) {
78             push @frames, "$frame[3] at $frame[1] line $frame[2]";
79              
80             # detect AnyEvent error in callback
81             if ( !defined $is_ae_cb_error ) {
82             if ( $frame[3] eq '(eval)' ) {
83             if ( $frame[0] eq 'AnyEvent::Impl::EV' ) {
84             $is_ae_cb_error = 1;
85             }
86             else {
87             $is_ae_cb_error = 0;
88             }
89             }
90             }
91             }
92              
93             $args{call_stack} = \join $LF, @frames;
94              
95             $args{timestamp} = Time::HiRes::time();
96              
97             # stringify $msg
98             $args{msg} = "$msg";
99              
100             # $args{msg} = "AE: error in callback: $args{msg}" if $is_ae_cb_error;
101              
102             return bless \%args, $self;
103             };
104              
105             # CLASS METHODS
106 0     0 0   sub PROPAGATE ( $self, $file, $line ) {
  0            
  0            
  0            
  0            
107 0           return $self;
108             }
109              
110 0     0     sub _build_exit_code ($self) {
  0            
  0            
111              
112             # return $! if $!; # errno
113             # return $? >> 8 if $? >> 8; # child exit status
114 0           return 255; # last resort
115             }
116              
117 0     0     sub _build_longmess ($self) {
  0            
  0            
118 0 0         if ( $self->{call_stack} ) {
119 0           return $self->{msg} . $LF . ( $self->{call_stack}->$* =~ s/^/ /smgr );
120             }
121             else {
122 0           return $self->{msg};
123             }
124             }
125              
126 0     0     sub _build_to_string ($self) {
  0            
  0            
127 0 0         return $self->{with_trace} ? $self->longmess : $self->{msg};
128             }
129              
130 0     0 0   sub sendlog ( $self, $level = undef ) {
  0            
  0            
  0            
131 0 0         return if $self->{is_logged}; # prevent logging the same exception twice
132              
133 0   0       $level //= $self->{level};
134              
135 0           $self->{is_logged} = 1;
136              
137 0 0         P->sendlog( "EXCEPTION.$level", $self->{msg}, $self->{with_trace} ? $self->{call_stack}->$* : undef );
138              
139 0           return;
140             }
141              
142             1;
143             __END__
144             =pod
145              
146             =encoding utf8
147              
148             =head1 NAME
149              
150             Pcore::Core::Exception::Object
151              
152             =head1 SYNOPSIS
153              
154             =head1 DESCRIPTION
155              
156             =cut