Commit v1.03 - liblog-report-perl

+11

-0

ChangeLog less more

5	5
6	6	TODO:
7	7	. connect to Message::Passing framework
	8
	9	version 1.03: Thu May 22 11:54:24 CEST 2014
	10
	11	Fixes:
	12	- float serialization under locale in test [cpantesters]
	13	- non-errors and ::Dispatcher::Perl
	14
	15	Improvements:
	16	- shorted display of string parameters in stack-trace to max 80 chars
	17	- Log4perl log-lines sometimes show dispatcher as source, skip them.
	18	- disable 'mode switch' trace for try()
8	19
9	20	version 1.02: Mon Mar 10 16:03:13 CET 2014
10	21

+1

-1

Makefile.PL less more

1	1
2	2	use 5.008;
3	3
4		my $version = '1.02';
	4	my $version = '1.03';
5	5
6	6	my %prereq =
7	7	( Test::More => '0.86'

+4

-5

lib/Log/Report/Die.pm less more

50	50	sub die_decode($)
51	51	{ my @text = split /\n/, $_[0];
52	52	@text or return ();
53
54		$text[0] =~ s/\.$//; # inconsequently used
55	53	chomp $text[-1];
56	54
57	55	my %opt = (errno => $! + 0);
58	56	my $err = "$!";
59	57
60	58	my $dietxt = $text[0];
61		if($text[0] =~ s/ at (.+) line (\d+)$// )
	59	if($text[0] =~ s/ at (.+) line (\d+)\.?$// )
62	60	{ $opt{location} = [undef, $1, $2, undef];
63	61	}
64	62	elsif(@text > 1 && $text[1] =~ m/^\s*at (.+) line (\d+)\.?$/ )
65		{ $opt{location} = [undef, $1, $2, undef];
	63	{ # sometimes people carp/confess with \n, folding the line
	64	$opt{location} = [undef, $1, $2, undef];
66	65	splice @text, 1, 1;
67	66	}
68	67
69		$text[0] =~ s/\s[.:;]?\s$err\s*$//
	68	$text[0] =~ s/\s[.:;]?\s$err\s*$// # the $err is translation sensitive
70	69	or delete $opt{errno};
71	70
72	71	my $msg = shift @text;

+7

-0

lib/Log/Report/Dispatcher/Log4perl.pm less more

25	25	@reasons==keys %default_reasonToLevel
26	26	or panic __"Not all reasons have a default translation";
27	27
	28	# Do not show these as source of the error: one or more caller frames up
	29	Log::Log4perl->wrapper_register($_) for qw/
	30	Log::Report
	31	Log::Report::Dispatcher
	32	Log::Report::Dispatcher::Try
	33	/;
	34
28	35	=chapter NAME
29	36	Log::Report::Dispatcher::Log4perl - send messages to Log::Log4perl back-end
30	37

+1

-9

lib/Log/Report/Dispatcher/Perl.pm less more

38	38
39	39	sub log($$$$)
40	40	{ my ($self, $opts, $reason, $message, $domain) = @_;
41		my $text = $self->translate($opts, $reason, $message);
42
43		if($opts->{is_fatal})
44		{ $! = $opts->{errno};
45		die $text;
46		}
47		else
48		{ warn $text;
49		}
	41	print STDERR $self->translate($opts, $reason, $message);
50	42	}
51	43
52	44	1;

+7

-6

lib/Log/Report/Dispatcher/Try.pm less more

73	73	, '""' => 'showStatus'
74	74	, fallback => 1;
75	75
	76	#-----------------
76	77	=chapter METHODS
77	78
78	79	=section Constructors

107	108	$self;
108	109	}
109	110
	111	#-----------------
110	112	=section Accessors
111	113
112	114	=method died [STRING]

126	128
127	129	sub exceptions() { @{shift->{exceptions}} }
128	130
	131	#-----------------
129	132	=section Logging
130	133
131	134	=method log $opts, $reason, $message

173	176	M<Log::Report::Exception::throw()> which does the job.
174	177	=cut
175	178
176		sub reportFatal(@) { $_->throw(@_) for shift->wasFatal }
177		sub reportAll(@) { $_->throw(@_) for shift->exceptions }
178
179
180		#-----------------
181
	179	sub reportFatal(@) { $_->throw(@_) for shift->wasFatal }
	180	sub reportAll(@) { $_->throw(@_) for shift->exceptions }
	181
	182	#-----------------
182	183	=section Status
183	184
184	185	=method failed

+12

-4

lib/Log/Report/Dispatcher.pm less more

208	208
209	209	$self->{needs} = [ expand_reasons $default_accept[$mode] ];
210	210
211		trace __x"switching to run mode {mode}, accept {accept}"
212		, mode => $mode, accept => $default_accept[$mode];
	211	trace __x"switching to run mode {mode} for {pkg}, accept {accept}"
	212	, mode => $mode, pkg => ref $self, accept => $default_accept[$mode]
	213	unless $self->isa('Log::Report::Dispatcher::Try');
213	214
214	215	$mode;
215	216	}

424	425	$max -= @params * 2 - length($listtail); # $ ( \,[ ] ){n-1} $
425	426
426	427	my $calling = $thing->stackTraceCall(\%args, $abstract, $call, $obj);
427		my @out = map {$thing->stackTraceParam(\%args, $abstract, $_)} @params;
	428	my @out = map $thing->stackTraceParam(\%args, $abstract, $_), @params;
428	429	my $total = sum map {length $_} $calling, @out;
429	430
430	431	ATTEMPT:

476	477	return $param # int or float
477	478	if $param =~ /^[+-]?(?:\d+(?:\.\d*)?\|\.\d+)(?:[eE][+-]?\d+)?$/;
478	479
479		'"' . escape_chars($param) . '"';
	480	my $escaped = escape_chars $param;
	481	if(length $escaped > 80)
	482	{ $escaped = substr($escaped, 0, 30)
	483	. '...['. (length($escaped) -80) .' chars more]...'
	484	. substr($escaped, -30);
	485	}
	486
	487	qq{"$escaped"};
480	488	}
481	489
482	490	=chapter DETAILS

+5

-17

lib/Log/Report.pm less more

225	225	my $stop = exists $opts->{is_fatal} ? $opts->{is_fatal} : is_fatal $reason;
226	226
227	227	my $try = $nested_tries[-1];
228		my @disp = ($stop && $try) ? () : @{$reporter->{needs}{$reason} \|\| []};
	228	my @disp = defined $try && $stop ? () : @{$reporter->{needs}{$reason}\|\|[]};
229	229	push @disp, $try if defined $try && $try->needs($reason);
230	230
231	231	# return when no-one needs it: skip unused trace() fast!

277	277	@disp or return;
278	278	}
279	279
280		my @last_call; # call Perl dispatcher always last, it calls real die
281	280	my $domain = $message->domain;
282	281	if(my $filters = $reporter->{filters})
283	282	{

289	288	($r, $m) = $filter->[0]->($d, $opts, $r, $m, $domain);
290	289	$r or next DISPATCHER;
291	290	}
292
293		if($d->isa('Log::Report::Dispatcher::Perl'))
294		{ @last_call = ($d, { %$opts }, $r, $m, $domain) }
295		else { $d->log($opts, $r, $m, $domain) }
	291	$d->log($opts, $r, $m, $domain);
296	292	}
297	293	}
298	294	else
299		{ foreach my $d (@disp)
300		{ if($d->isa('Log::Report::Dispatcher::Perl'))
301		{ @last_call = ($d, { %$opts }, $reason, $message, $domain) }
302		else { $d->log($opts, $reason, $message, $domain) }
303		}
304		}
305
306		if(@last_call && !$^S)
307		{ # the PERL dispatcher may terminate the program
308		shift(@last_call)->log(@last_call);
	295	{ $_->log($opts, $reason, $message, $domain) for @disp;
309	296	}
310	297
311	298	if($stop)

872	859	if($INC{'Log/Report/Minimal.pm'})
873	860	{ my ($pkg, $fn, $line) = caller; # do not report on LR:: modules
874	861	if(index($pkg, 'Log::Report::') != 0)
875		{ my @pkgs = Log::Report::Optional->usedBy;
	862	{ # @pkgs empty during release testings of L::R distributions
	863	my @pkgs = Log::Report::Optional->usedBy;
876	864	die "Log::Report loaded too late in $fn line $line, "
877	865	. "put in $pkg before ", (join ',', @pkgs) if @pkgs;
878	866	}

+8

-4

t/10interp.t less more

14	14
15	15	sub ol_is($$;$)
16	16	{ # since Test::More 0.95_01, is() does not stringify its arguments.
17		# This means that overloading does not quick in. How to test
	17	# This means that overloading does not kick in. How to test
18	18	# overloading now?
19	19	my ($f, $s, $comment) = @_;
20	20	overload::Overloaded($f) \|\| overload::Overloaded($s)

139	139
140	140	use constant PI => 4 * atan2(1, 1);
141	141	my $approx = 'approx pi: 3.141593';
142		is((sprintf "approx pi: %.6f", PI), $approx);
143		ol_is((__x "approx pi: {approx}", approx => sprintf("%.6f", PI)), $approx);
144		ol_is((__x "approx pi: {pi%.6f}", pi => PI), $approx);
	142	is((sprintf "approx pi: %.6f", PI), $approx, 'sprintf');
	143	ol_is((__x "approx pi: {approx}", approx => sprintf("%.6f", PI)), $approx,
	144	'sprintf nested');
	145
	146	my $app = __x "approx pi: {pi%.6f}", pi => PI;
	147	$app =~ s/\,/./g; # translated under locale, which may use ','
	148	ol_is($app, $approx, 'interpolated format');
145	149
146	150	ol_is((__x "{perms} {links%2d} {user%-8s} {size%8d} {fn}"
147	151	, perms => '-rw-r--r--', links => 1, user => 'superman'