1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
|
# Copyrights 2007-2025 by [Mark Overmeer <markov@cpan.org>].
# For other contributors see ChangeLog.
# See the manual pages for details on the licensing terms.
# Pod stripped from pm file by OODoc 2.03.
# This code is part of distribution Log-Report. Meta-POD processed with
# OODoc into POD and HTML manual-pages. See README.md
# Copyright Mark Overmeer. Licensed under the same terms as Perl itself.
package Log::Report::Dispatcher::Try;{
our $VERSION = '1.40';
}
use base 'Log::Report::Dispatcher';
use warnings;
use strict;
use Log::Report 'log-report', syntax => 'SHORT';
use Log::Report::Exception ();
use Log::Report::Util qw/%reason_code expand_reasons/;
use List::Util qw/first/;
use overload
bool => 'failed'
, '""' => 'showStatus'
, fallback => 1;
#-----------------
sub init($)
{ my ($self, $args) = @_;
defined $self->SUPER::init($args) or return;
$self->{exceptions} = delete $args->{exceptions} || [];
$self->{died} = delete $args->{died};
$self->hide($args->{hide} // 'NONE');
$self->{on_die} = $args->{on_die} // 'ERROR';
$self;
}
#-----------------
sub died(;$)
{ my $self = shift;
@_ ? ($self->{died} = shift) : $self->{died};
}
sub exceptions() { @{shift->{exceptions}} }
sub hides($) { $_[0]->{LRDT_hides}{$_[1]} }
sub hide(@)
{ my $self = shift;
my @reasons = expand_reasons(@_ > 1 ? \@_ : shift);
$self->{LRDT_hides} = +{ map +($_ => 1), @reasons };
}
sub die2reason() { shift->{on_die} }
#-----------------
sub log($$$$)
{ my ($self, $opts, $reason, $message, $domain) = @_;
unless($opts->{stack})
{ my $mode = $self->mode;
$opts->{stack} = $self->collectStack
if $reason eq 'PANIC'
|| ($mode==2 && $reason_code{$reason} >= $reason_code{ALERT})
|| ($mode==3 && $reason_code{$reason} >= $reason_code{ERROR});
}
$opts->{location} ||= '';
my $e = Log::Report::Exception->new
( reason => $reason
, report_opts => $opts
, message => $message
);
push @{$self->{exceptions}}, $e;
$self;
}
sub reportFatal(@) { $_->throw(@_) for shift->wasFatal }
sub reportAll(@) { $_->throw(@_) for shift->exceptions }
#-----------------
sub failed() { defined shift->{died} }
sub success() { ! defined shift->{died} }
sub wasFatal(@)
{ my ($self, %args) = @_;
defined $self->{died} or return ();
my $ex = first { $_->isFatal } @{$self->{exceptions}}
or return ();
# There can only be one fatal exception. Is it in the class?
(!$args{class} || $ex->inClass($args{class})) ? $ex : ();
}
sub showStatus()
{ my $self = shift;
my $fatal = $self->wasFatal or return '';
__x"try-block stopped with {reason}: {text}"
, reason => $fatal->reason
, text => $self->died;
}
1;
|
