Commit aa0e96b6f317b746d7f84748a77219c933b823bd - liblog-report-perl

distribution Log-Report-1.23.tar.gz Mark Overmeer authored 6 years ago Mark Overmeer committed 6 years ago

8 changed file(s) with 259 addition(s) and 6 deletion(s). Raw diff Collapse all Expand all

-0

ChangeLog less more

5	5
6	6	TODO:
7	7	. connect to Message::Passing framework
	8
	9	version 1.23: Thu 2 Nov 10:40:24 CET 2017
	10
	11	Improvements:
	12	- understand objects in report() rt.cpan.org #123241 [Andy Beverley]
	13	- understand DBIx::Class::Exception in try{}
	14	- understand XML::LibXML::Error in try{}
8	15
9	16	version 1.22: Thu 12 Oct 12:18:54 CEST 2017
10	17

-0

MANIFEST less more

30	30	t/11concat.t
31	31	t/31stack.t
32	32	t/41die.t
	33	t/42exc-dbix-class.t
	34	t/43exc-xml-libxml.t
33	35	t/50file.t
34	36	t/51syslog.t
35	37	t/52logdisp.t

-1

Makefile.PL less more

1	1
2	2	use 5.010;
3	3
4		my $version = '1.22';
	4	my $version = '1.23';
5	5
6	6	my %prereq =
7	7	( Test::More => '0.86'

+88

-2

lib/Log/Report/Die.pm less more

3	3	package Log::Report::Die;
4	4	use base 'Exporter';
5	5
6		our @EXPORT = qw/die_decode/;
	6	our @EXPORT = qw/die_decode exception_decode/;
7	7
8	8	use POSIX qw/locale_h/;
9	9

11	11	Log::Report::Die - compatibility routines with Perl's die/croak/confess
12	12
13	13	=chapter SYNOPSIS
	14	# use internally only
14	15
15	16	=chapter DESCRIPTION
16	17
17	18	This module is used internally, to translate output of 'die' and Carp
18		functions into M<Log::Report::Message> objects.
	19	functions into M<Log::Report::Message> objects. Also, it tries to
	20	convert other kinds of exception frameworks into our message object.
19	21
20	22	=chapter FUNCTIONS
21	23

92	94	($dietxt, \%opt, $reason, join("\n", @msg));
93	95	}
94	96
	97	=function exception_decode $exception, %options
	98	[1.23] This function attempts to translate object of other exception frameworks
	99	into information to create a M<Log::Report::Exception>. It returns the
	100	same list of parameters as M<die_decode()> does.
	101
	102	Currently supported:
	103	=over 4
	104	=item * DBIx::Class::Exception
	105	=item * XML::LibXML::Error
	106	=back
	107	=cut
	108
	109	sub _exception_dbix($$)
	110	{ my ($exception, $args) = @_;
	111	my $on_die = delete $args->{on_die};
	112	my %opts = %$args;
	113
	114	my @lines = split /\n/, "$exception"; # accessor missing to get msg
	115	my $first = shift @lines;
	116	my ($sub, $message, $fn, $linenr) = $first =~
	117	m/^ (?: ([\w:]+?) \: [ ] \| \{UNKNOWN\}\: [ ] )?
	118	(.*?)
	119	\s+ at [ ] (.+) [ ] line [ ] ([0-9]+)\.?
	120	$/x;
	121	my $pkg = defined $sub && $sub =~ s/^([\w:]+)\:\:// ? $1 : $0;
	122
	123	$opts{location} \|\|= [ $pkg, $fn, $linenr, $sub ];
	124
	125	my @stack;
	126	foreach (@lines)
	127	{ my ($func, $fn, $linenr)
	128	= /^\s+(.?)\s+called at (.?) line ([0-9]+)$/ or next;
	129	push @stack, [ $func, $fn, $linenr ];
	130	}
	131	$opts{stack} \|\|= \@stack if @stack;
	132
	133	my $reason
	134	= $opts{errno} ? 'FAULT'
	135	: @stack ? 'PANIC'
	136	: $on_die \|\| 'ERROR';
	137
	138	('caught '.ref $exception, \%opts, $reason, $message);
	139	}
	140
	141	my %_libxml_errno2reason = (1 => 'WARNING', 2 => 'MISTAKE', 3 => 'ERROR');
	142
	143	sub _exception_libxml($$)
	144	{ my ($exc, $args) = @_;
	145	my $on_die = delete $args->{on_die};
	146	my %opts = %$args;
	147
	148	$opts{errno} \|\|= $exc->code + 13000;
	149	$opts{location} \|\|= [ 'libxml', $exc->file, $exc->line, $exc->domain ];
	150
	151	my $msg = $exc->message . $exc->context . "\n"
	152	. (' ' x $exc->column) . '^'
	153	. ' (' . $exc->domain . ' error ' . $exc->code . ')';
	154
	155	my $reason = $_libxml_errno2reason{$exc->level} \|\| 'PANIC';
	156	('caught '.ref $exc, \%opts, $reason, $msg);
	157	}
	158
	159	sub exception_decode($%)
	160	{ my ($exception, %args) = @_;
	161	my $errno = $! + 0;
	162
	163	return _exception_dbix($exception, \%args)
	164	if $exception->isa('DBIx::Class::Exception');
	165
	166	return _exception_libxml($exception, \%args)
	167	if $exception->isa('XML::LibXML::Error');
	168
	169	# Unsupported exception system, sane guesses
	170	my %opt =
	171	( classes => [ 'unknown exception', 'die', ref $exception ]
	172	, errno => $errno
	173	);
	174
	175	my $reason = $errno ? 'FAULT' : $args{on_die} \|\| 'ERROR';
	176
	177	# hopefully stringification is overloaded
	178	( "caught ".ref $exception, \%opt, $reason, "$exception");
	179	}
	180
95	181	"to die or not to die, that's the question";

-0

lib/Log/Report/Exception.pm less more

59	59	bless \%args, $class;
60	60	}
61	61
	62	#----------------
62	63	=section Accessors
63	64
64	65	=method report_opts

108	109	$self->{message} = $msg;
109	110	}
110	111
	112	#----------------
111	113	=section Processing
112	114
113	115	=method inClass $class\|Regexp

+15

-3

lib/Log/Report.pm less more

35	35	my @nested_tries;
36	36
37	37	# we can only load these after Log::Report has compiled, because
38		# the use this module themselves.
	38	# they use this module themselves as well.
39	39
40	40	require Log::Report::Die;
41	41	require Log::Report::Domain;

273	273	}
274	274	elsif($message->isa('Log::Report::Message'))
275	275	{ @_==0 or error __x"a message object is reported with more parameters";
	276	}
	277	else
	278	{ # foreign object
	279	my $text = "$message"; # hope stringification is overloaded
	280	$text =~ s/\s*$//gs;
	281	@_%2 and error __x"odd length parameter list with object '{msg}'",
	282	msg => $text;
	283	$message = $lrm->new(_prepend => $text, @_);
276	284	}
277	285
278	286	if(my $to = $message->to)

570	578
571	579	my $is_exception = blessed $err && $err->isa('Log::Report::Exception');
572	580	if(!$is_exception && $err && !$disp->wasFatal)
573		{ ($err, my($opts, $reason, $text))
574		= Log::Report::Die::die_decode($err, on_die => $disp->die2reason);
	581	{ # Decode exceptions which do not origin from Log::Report reports
	582	($err, my($opts, $reason, $text)) = blessed $err
	583	? Log::Report::Die::exception_decode($err)
	584	: Log::Report::Die::die_decode($err, on_die => $disp->die2reason);
	585
575	586	$disp->log($opts, $reason, __$text);
576	587	}
577	588

583	594	wantarray ? @ret : $ret;
584	595	}
585	596
	597	#------------
586	598	=section Abbreviations for report()
587	599
588	600	The following functions are all wrappers for calls to M<report()>,

+102

-0

t/42exc-dbix-class.t less more

	0	#!/usr/bin/env perl
	1	# Convert dbix exceptions into report
	2
	3	use warnings;
	4	use strict;
	5
	6	use Log::Report;
	7	use Log::Report::Die 'exception_decode';
	8	use Test::More;
	9
	10	use Data::Dumper;
	11
	12	$! = 3;
	13	my $errno = $!+0;
	14
	15	{ # I do not want a dependency: fake implementation of this object
	16	package DBIx::Class::Exception;
	17	sub new($) { bless { msg => $_[1] }, $_[0] }
	18	use overload '""' => sub { shift->{msg} }, fallback => 1;
	19	}
	20	sub exception($) { DBIx::Class::Exception->new($_[0]) }
	21
	22	my $dbix1 = <<__WITHOUT_STACKTRACE;
	23	help at /tmp/a.pl line 6.
	24	__WITHOUT_STACKTRACE
	25
	26	is_deeply [ exception_decode(exception $dbix1) ]
	27	, [ 'caught DBIx::Class::Exception'
	28	, { location => [ $0, '/tmp/a.pl', '6', undef ] }
	29	, 'ERROR'
	30	, 'help'
	31	], 'set 1';
	32
	33	my $dbix2 = <<__WITH_STACKTRACE;
	34	main::f(): help at /tmp/a.pl line 6.
	35	main::f() called at /tmp/a.pl line 8
	36	main::g() called at /tmp/a.pl line 10
	37	__WITH_STACKTRACE
	38
	39	is_deeply [ exception_decode(exception $dbix2) ]
	40	, [ 'caught DBIx::Class::Exception'
	41	, { location => [ 'main', '/tmp/a.pl', '6', 'f' ]
	42	, stack => [ [ 'main::f', '/tmp/a.pl', '8' ]
	43	, [ 'main::g', '/tmp/a.pl', '10' ]
	44	]
	45	}
	46	, 'PANIC'
	47	, 'help'
	48	], 'set 2';
	49
	50	my $dbix3 = <<__WITHOUT_STACKTRACE; # not inside function
	51	{UNKNOWN}: help at /tmp/a.pl line 6.
	52	__WITHOUT_STACKTRACE
	53
	54	is_deeply [ exception_decode(exception $dbix3) ]
	55	, [ 'caught DBIx::Class::Exception'
	56	, { location => [ $0, '/tmp/a.pl', '6', undef ] }
	57	, 'ERROR'
	58	, 'help'
	59	], 'set 3';
	60
	61	my $dbix4 = <<'__FROM_DB'; # contributed by Andrew
	62	DBIx::Class::Storage::DBI::_dbh_execute(): DBI Exception: DBD::Pg::st execute failed: ERROR: duplicate key value violates unique constraint "gdpaanswer_pkey" DETAIL: Key (identifier)=(18.5) already exists. [for Statement "INSERT INTO "gdpaanswer" ( "answer", "identifier", "section", "site_id") VALUES ( ?, ?, ?, ?)" with ParamValues: 1='2', 2='18.5', 3='18', 4=undef] at /home/abeverley/git/Isaas/bin/../lib/Isaas/DBIC.pm line 18
	63	__FROM_DB
	64
	65	#warn "DBIx4:", Dumper exception_decode(exception $dbix4);
	66
	67	is_deeply [ exception_decode(exception $dbix4) ]
	68	, [ 'caught DBIx::Class::Exception'
	69	, { location =>
	70	[ 'DBIx::Class::Storage::DBI'
	71	, '/home/abeverley/git/Isaas/bin/../lib/Isaas/DBIC.pm'
	72	, '18'
	73	, '_dbh_execute'
	74	] }
	75	, 'ERROR'
	76	, q{DBI Exception: DBD::Pg::st execute failed: ERROR: duplicate key value violates unique constraint "gdpaanswer_pkey" DETAIL: Key (identifier)=(18.5) already exists. [for Statement "INSERT INTO "gdpaanswer" ( "answer", "identifier", "section", "site_id") VALUES ( ?, ?, ?, ?)" with ParamValues: 1='2', 2='18.5', 3='18', 4=undef]}
	77	], 'set 4';
	78
	79
	80	### Test automatic conversion
	81
	82	try { die exception $dbix1 };
	83	my $exc = $@->wasFatal;
	84	isa_ok $exc, 'Log::Report::Exception';
	85	is "$exc", "error: help\n";
	86
	87	my $msg = $exc->message;
	88	isa_ok $msg, 'Log::Report::Message';
	89	is $msg->toString, 'help';
	90
	91
	92	### Test report with object
	93
	94	try { error exception $dbix1 };
	95	my $err = $@->wasFatal;
	96	isa_ok $err, 'Log::Report::Exception';
	97	is "$err", "error: help at /tmp/a.pl line 6.\n";
	98
	99	done_testing;
	100
	101	1;

+42

-0

t/43exc-xml-libxml.t less more

	0	#!/usr/bin/env perl
	1	# Convert XML::LibXML exceptions into report
	2
	3	use warnings;
	4	use strict;
	5
	6	use Log::Report;
	7	use Log::Report::Die 'exception_decode';
	8	use Test::More;
	9
	10	#use Data::Dumper;
	11
	12	BEGIN {
	13	eval 'require XML::LibXML::Error';
	14	plan skip_all => 'XML::LibXML::Error not available' if $@;
	15
	16	eval 'require XML::LibXML';
	17	plan skip_all => 'Your installation of XML::LibXML is broken' if $@;
	18	}
	19
	20	# The XML::LibXML::Error object does not have a constructor, so we
	21	# need to trigger one.
	22	my $xml = eval { XML::LibXML->load_xml(string => \'<bad-xml>') };
	23	ok ! defined $xml, 'parse broken xml';
	24	my $error = $@;
	25	isa_ok $error, 'XML::LibXML::Error';
	26
	27	#warn Dumper exception_decode($error);
	28	my @dec = exception_decode($error);
	29	my $msg = pop @dec;
	30	is_deeply \@dec,
	31	, [ 'caught XML::LibXML::Error'
	32	, { location => [ 'libxml', '', '1', 'parser' ], errno => 13077 }
	33	, 'ERROR'
	34	], 'error 1';
	35
	36	# the message may vary over libxml2 versions
	37	like $msg, qr/bad\-xml/, $msg;
	38
	39	done_testing;
	40
	41	1;