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
121
122
123
124
125
126
127
128
129
|
# This code is part of Perl distribution Log-Report version 1.41.
# The POD got stripped from this file by OODoc version 3.04.
# For contributors see file ChangeLog.
# This software is copyright (c) 2007-2025 by Mark Overmeer.
# This is free software; you can redistribute it and/or modify it under
# the same terms as the Perl 5 programming language system itself.
# SPDX-License-Identifier: Artistic-1.0-Perl OR GPL-1.0-or-later
#oodist: *** DO NOT USE THIS VERSION FOR PRODUCTION ***
#oodist: This file contains OODoc-style documentation which will get stripped
#oodist: during its release in the distribution. You can use this file for
#oodist: testing, however the code of this development version may be broken!
#oorestyle: not found P for overload boolean($@)
#oorestyle: not found P for overload stringify($@)
#oorestyle: not found P for method reportFatal(%options)
#oorestyle: not found P for method reportFatal(%options)
#oorestyle: not found P for method showStatus($@)
#oorestyle: not found P for method showStatus($@)
package Log::Report::Dispatcher::Try;{
our $VERSION = '1.41';
}
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() { @{ $_[0]->{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() { $_[0]->{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} ||= '';
push @{$self->{exceptions}},
Log::Report::Exception->new(reason => $reason, report_opts => $opts, message => $message);
$self;
}
sub reportFatal(@) { my $s = shift; $_->throw(@_) for $s->wasFatal }
sub reportAll(@) { my $s = shift; $_->throw(@_) for $s->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;
|
