File: Exception.pm

package info (click to toggle)
liblog-report-perl 1.41-1
  • links: PTS, VCS
  • area: main
  • in suites: forky, sid
  • size: 572 kB
  • sloc: perl: 2,819; makefile: 8
file content (112 lines) | stat: -rw-r--r-- 2,540 bytes parent folder | download
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
# 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!

package Log::Report::Exception;{
our $VERSION = '1.41';
}


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() { $_[0]->{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}}, @_ );

	my $reason;
	if($reason = delete $opts{reason})
	{	exists $opts{is_fatal} or $opts{is_fatal} = is_fatal $reason;
	}
	else
	{	$reason = $self->{reason};
	}

	$opts{stack} ||= Log::Report::Dispatcher->collectStack;
	report \%opts, $reason, $self;
}

# where the throw is handled is not interesting
sub PROPAGATE($$) { $_[0] }


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;