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
|
# 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::Exception;{
our $VERSION = '1.40';
}
use warnings;
use strict;
use Log::Report 'log-report';
use Log::Report::Util qw/is_fatal to_html/;
use POSIX qw/locale_h/;
use Scalar::Util qw/blessed/;
use overload
'""' => 'toString'
, 'bool' => sub {1} # avoid accidental serialization of message
, fallback => 1;
sub new($@)
{ my ($class, %args) = @_;
$args{report_opts} ||= {};
bless \%args, $class;
}
#----------------
sub report_opts() {shift->{report_opts}}
sub reason(;$)
{ my $self = shift;
@_ ? $self->{reason} = uc(shift) : $self->{reason};
}
sub isFatal()
{ my $self = shift;
my $opts = $self->report_opts;
exists $opts->{is_fatal} ? $opts->{is_fatal} : is_fatal $self->{reason};
}
sub message(;$)
{ my $self = shift;
@_ or return $self->{message};
my $msg = shift;
blessed $msg && $msg->isa('Log::Report::Message')
or panic "message() of exception expects Log::Report::Message";
$self->{message} = $msg;
}
#----------------
sub inClass($) { $_[0]->message->inClass($_[1]) }
sub throw(@)
{ my $self = shift;
my $opts = @_ ? { %{$self->{report_opts}}, @_ } : $self->{report_opts};
my $reason;
if($reason = delete $opts->{reason})
{ $self->{reason} = $reason;
$opts->{is_fatal} = is_fatal $reason
unless exists $opts->{is_fatal};
}
else
{ $reason = $self->{reason};
}
$opts->{stack} ||= Log::Report::Dispatcher->collectStack;
report $opts, $reason, $self;
}
# where the throw is handled is not interesting
sub PROPAGATE($$) {shift}
sub toString(;$)
{ my ($self, $locale) = @_;
my $msg = $self->message;
lc($self->{reason}).': '.(ref $msg ? $msg->toString($locale) : $msg)."\n";
}
sub toHTML(;$) { to_html($_[0]->toString($_[1])) }
sub print(;$)
{ my $self = shift;
(shift || *STDERR)->print($self->toString);
}
1;
|
