view release on metacpan or  search on metacpan

lib/Log/Report.pm  view on Meta::CPAN

# This code is part of Perl distribution Log-Report version 1.46.
# The POD got stripped from this file by OODoc version 3.06.
# For contributors see file ChangeLog.

# This software is copyright (c) 2007-2026 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


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

use base 'Exporter';

use warnings;
use strict;

use List::Util         qw/first/;
use Scalar::Util       qw/blessed/;

use Log::Report::Util;
my $lrm = 'Log::Report::Message';

### if you change anything here, you also have to change Log::Report::Minimal
my @make_msg   = qw/__ __x __n __nx __xn N__ N__n N__w __p __px __np __npx/;
my @functions  = qw/report dispatcher try textdomain default_dispatcher_mode/;
my @reason_functions = qw/trace assert info notice warning mistake error fault alert failure panic/;

our @EXPORT_OK = (@make_msg, @functions, @reason_functions);

sub _whats_needed(); sub dispatcher($@); sub textdomain(@);
sub trace(@); sub assert(@); sub info(@); sub notice(@); sub warning(@);
sub mistake(@); sub error(@); sub fault(@); sub alert(@); sub failure(@);
sub panic(@);
sub __($); sub __x($@); sub __n($$$@); sub __nx($$$@); sub __xn($$$@);
sub N__($); sub N__n($$); sub N__w(@);
sub __p($$); sub __px($$@); sub __np($$$$); sub __npx($$$$@);

#
# Some initiations
#

my $reporter     = {};
my $default_mode = 0;
my @nested_tries;

# we can only load these after Log::Report has compiled, because
# they use this module themselves as well.

require Log::Report::Die;
require Log::Report::Domain;
require Log::Report::Message;
require Log::Report::Exception;
require Log::Report::Dispatcher;
require Log::Report::Dispatcher::Try;

textdomain 'log-report';

my $default_dispatcher = dispatcher PERL => 'default', accept => 'NOTICE-';

#--------------------

sub report($@)
{	my $opts = ref $_[0] eq 'HASH' ? +{ %{ (shift) } } : {};
	my ($reason, $message) = (shift, shift);

	my $stop = exists $opts->{is_fatal} ? $opts->{is_fatal} : is_fatal $reason;
	my $try  = $nested_tries[-1];  # WARNING: overloaded boolean, use 'defined'

	my @disp;
	if(defined $try)
	{	push @disp, @{$reporter->{needs}{$reason} || []}
			unless $stop || $try->hides($reason);

		push @disp, $try
			if $try->needs($reason) || $opts->{is_fatal};
	}
	else
	{	@disp = @{$reporter->{needs}{$reason} || []};
	}

	is_reason $reason
		or error __x"token '{token UNKNOWN}' not recognized as reason.", token => $reason;

	# return when no-one needs it: skip unused trace() fast!
	@disp || $stop
		or return;

	my $to = delete $opts->{to};
	if($to)
	{	# explicit destination, still disp may not need it.
		if(ref $to eq 'ARRAY')
		{	my %disp = map +($_->name => $_), @disp;
			@disp	 = grep defined, @disp{@$to};
		}

lib/Log/Report.pm  view on Meta::CPAN

{	my $code = shift;

	@_ % 2 and report +{ location => [caller 0] },
		PANIC => __"odd length parameter list for try(): forgot the terminating ';'?";

	unshift @_, mode => 'DEBUG'
		if $reporter->{needs}{TRACE};

	my $disp = Log::Report::Dispatcher::Try->new(TRY => 'try', @_);

	# L::R native messages are logged directly in $disp via @nested_tries
	push @nested_tries, $disp;

	# user's __DIE__ handlers would frustrate the exception mechanism
	local $SIG{__DIE__};

	my ($ret, @ret);
	if(!defined wantarray)  { eval { $code->() } } # VOID   context
	elsif(wantarray) { @ret = eval { $code->() } } # LIST   context
	else			 { $ret = eval { $code->() } } # SCALAR context

	my $err  = $@;
	pop @nested_tries;   # remove $disp

	my $is_exception = blessed $err && $err->isa('Log::Report::Exception');
	if(!$is_exception && $err && !$disp->wasFatal)
	{	# Decode errors which do not origin from Log::Report reports
		# Native exceptions are already logged.
		my ($opts, $reason, $text, $tags) = blessed $err
		  ? Log::Report::Die::exception_decode($err)
		  : Log::Report::Die::die_decode($err, on_die => $disp->die2reason);

		$disp->log($opts, $reason, __x($text, _tags => $tags));
	}

	$disp->died($err)
		if $is_exception ? $err->isFatal : $err;

	$@ = $disp;

	wantarray ? @ret : $ret;
}

#--------------------

sub trace(@)   {report TRACE   => @_}
sub assert(@)  {report ASSERT  => @_}
sub info(@)    {report INFO    => @_}
sub notice(@)  {report NOTICE  => @_}
sub warning(@) {report WARNING => @_}
sub mistake(@) {report MISTAKE => @_}
sub error(@)   {report ERROR   => @_}
sub fault(@)   {report FAULT   => @_}
sub alert(@)   {report ALERT   => @_}
sub failure(@) {report FAILURE => @_}
sub panic(@)   {report PANIC   => @_}

#--------------------


sub __($)
{	my ($cpkg, $fn, $linenr) = caller;
	$lrm->new(_msgid  => shift, _domain => pkg2domain($cpkg), _use => "$fn line $linenr");
}


# label "msgid" added before first argument
sub __x($@)
{	my ($cpkg, $fn, $linenr) = caller;
	@_%2 or error __x"even length parameter list for __x at {where}", where => "$fn line $linenr";

	my $msgid = shift;
	$lrm->new(_msgid => $msgid, _expand => 1, _domain => pkg2domain($cpkg), _use => "$fn line $linenr", @_);
}


sub __n($$$@)
{	my ($single, $plural, $count) = (shift, shift, shift);
	my ($cpkg, $fn, $linenr) = caller;
	$lrm->new(_msgid => $single, _plural => $plural, _count => $count, _domain => pkg2domain($cpkg),
		_use => "$fn line $linenr" , @_);
}


sub __nx($$$@)
{	my ($single, $plural, $count) = (shift, shift, shift);
	my ($cpkg, $fn, $linenr) = caller;
	$lrm->new(_msgid => $single, _plural => $plural, _count => $count, _expand => 1,
		_domain => pkg2domain($cpkg), _use => "$fn line $linenr", @_);
}


sub __xn($$$@)   # repeated for prototype
{	my ($single, $plural, $count) = (shift, shift, shift);
	my ($cpkg, $fn, $linenr) = caller;
	$lrm->new(_msgid => $single, _plural => $plural, _count => $count, _expand => 1,
		_domain => pkg2domain($cpkg), _use => "$fn line $linenr", @_);
}


sub N__($) { $_[0] }


sub N__n($$) {@_}


sub N__w(@) {split " ", $_[0]}


#--------------------

sub __p($$) { __($_[0])->_msgctxt($_[1]) }

sub __px($$@)
{	my ($ctxt, $msgid) = (shift, shift);
	__x($msgid, @_)->_msgctxt($ctxt);
}

sub __np($$$$)
{	my ($ctxt, $msgid, $plural, $count) = @_;
	__n($msgid, $msgid, $plural, $count)->_msgctxt($ctxt);