diff --git a/ChangeLog b/ChangeLog index 4a3f89c..e659713 100644 --- a/ChangeLog +++ b/ChangeLog @@ -6,6 +6,13 @@ TODO: . connect to Message::Passing framework + +version 1.23: Thu 2 Nov 10:40:24 CET 2017 + + Improvements: + - understand objects in report() rt.cpan.org #123241 [Andy Beverley] + - understand DBIx::Class::Exception in try{} + - understand XML::LibXML::Error in try{} version 1.22: Thu 12 Oct 12:18:54 CEST 2017 diff --git a/MANIFEST b/MANIFEST index 3813acc..cc3f8de 100644 --- a/MANIFEST +++ b/MANIFEST @@ -31,6 +31,8 @@ t/11concat.t t/31stack.t t/41die.t +t/42exc-dbix-class.t +t/43exc-xml-libxml.t t/50file.t t/51syslog.t t/52logdisp.t diff --git a/Makefile.PL b/Makefile.PL index 6d46e16..7a8570f 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -2,7 +2,7 @@ use 5.010; -my $version = '1.22'; +my $version = '1.23'; my %prereq = ( Test::More => '0.86' diff --git a/lib/Log/Report/Die.pm b/lib/Log/Report/Die.pm index 4314294..4e3c399 100644 --- a/lib/Log/Report/Die.pm +++ b/lib/Log/Report/Die.pm @@ -4,7 +4,7 @@ package Log::Report::Die; use base 'Exporter'; -our @EXPORT = qw/die_decode/; +our @EXPORT = qw/die_decode exception_decode/; use POSIX qw/locale_h/; @@ -12,11 +12,13 @@ Log::Report::Die - compatibility routines with Perl's die/croak/confess =chapter SYNOPSIS + # use internally only =chapter DESCRIPTION This module is used internally, to translate output of 'die' and Carp -functions into M objects. +functions into M objects. Also, it tries to +convert other kinds of exception frameworks into our message object. =chapter FUNCTIONS @@ -93,4 +95,88 @@ ($dietxt, \%opt, $reason, join("\n", @msg)); } +=function exception_decode $exception, %options +[1.23] This function attempts to translate object of other exception frameworks +into information to create a M. It returns the +same list of parameters as M does. + +Currently supported: +=over 4 +=item * DBIx::Class::Exception +=item * XML::LibXML::Error +=back +=cut + +sub _exception_dbix($$) +{ my ($exception, $args) = @_; + my $on_die = delete $args->{on_die}; + my %opts = %$args; + + my @lines = split /\n/, "$exception"; # accessor missing to get msg + my $first = shift @lines; + my ($sub, $message, $fn, $linenr) = $first =~ + m/^ (?: ([\w:]+?) \(\)\: [ ] | \{UNKNOWN\}\: [ ] )? + (.*?) + \s+ at [ ] (.+) [ ] line [ ] ([0-9]+)\.? + $/x; + my $pkg = defined $sub && $sub =~ s/^([\w:]+)\:\:// ? $1 : $0; + + $opts{location} ||= [ $pkg, $fn, $linenr, $sub ]; + + my @stack; + foreach (@lines) + { my ($func, $fn, $linenr) + = /^\s+(.*?)\(\)\s+called at (.*?) line ([0-9]+)$/ or next; + push @stack, [ $func, $fn, $linenr ]; + } + $opts{stack} ||= \@stack if @stack; + + my $reason + = $opts{errno} ? 'FAULT' + : @stack ? 'PANIC' + : $on_die || 'ERROR'; + + ('caught '.ref $exception, \%opts, $reason, $message); +} + +my %_libxml_errno2reason = (1 => 'WARNING', 2 => 'MISTAKE', 3 => 'ERROR'); + +sub _exception_libxml($$) +{ my ($exc, $args) = @_; + my $on_die = delete $args->{on_die}; + my %opts = %$args; + + $opts{errno} ||= $exc->code + 13000; + $opts{location} ||= [ 'libxml', $exc->file, $exc->line, $exc->domain ]; + + my $msg = $exc->message . $exc->context . "\n" + . (' ' x $exc->column) . '^' + . ' (' . $exc->domain . ' error ' . $exc->code . ')'; + + my $reason = $_libxml_errno2reason{$exc->level} || 'PANIC'; + ('caught '.ref $exc, \%opts, $reason, $msg); +} + +sub exception_decode($%) +{ my ($exception, %args) = @_; + my $errno = $! + 0; + + return _exception_dbix($exception, \%args) + if $exception->isa('DBIx::Class::Exception'); + + return _exception_libxml($exception, \%args) + if $exception->isa('XML::LibXML::Error'); + + # Unsupported exception system, sane guesses + my %opt = + ( classes => [ 'unknown exception', 'die', ref $exception ] + , errno => $errno + ); + + my $reason = $errno ? 'FAULT' : $args{on_die} || 'ERROR'; + + # hopefully stringification is overloaded + ( "caught ".ref $exception, \%opt, $reason, "$exception"); +} + "to die or not to die, that's the question"; diff --git a/lib/Log/Report/Exception.pm b/lib/Log/Report/Exception.pm index b3b5fda..b1c2d86 100644 --- a/lib/Log/Report/Exception.pm +++ b/lib/Log/Report/Exception.pm @@ -60,6 +60,7 @@ bless \%args, $class; } +#---------------- =section Accessors =method report_opts @@ -109,6 +110,7 @@ $self->{message} = $msg; } +#---------------- =section Processing =method inClass $class|Regexp diff --git a/lib/Log/Report.pm b/lib/Log/Report.pm index eb64229..164a593 100644 --- a/lib/Log/Report.pm +++ b/lib/Log/Report.pm @@ -36,7 +36,7 @@ my @nested_tries; # we can only load these after Log::Report has compiled, because -# the use this module themselves. +# they use this module themselves as well. require Log::Report::Die; require Log::Report::Domain; @@ -274,6 +274,14 @@ } elsif($message->isa('Log::Report::Message')) { @_==0 or error __x"a message object is reported with more parameters"; + } + else + { # foreign object + my $text = "$message"; # hope stringification is overloaded + $text =~ s/\s*$//gs; + @_%2 and error __x"odd length parameter list with object '{msg}'", + msg => $text; + $message = $lrm->new(_prepend => $text, @_); } if(my $to = $message->to) @@ -571,8 +579,11 @@ my $is_exception = blessed $err && $err->isa('Log::Report::Exception'); if(!$is_exception && $err && !$disp->wasFatal) - { ($err, my($opts, $reason, $text)) - = Log::Report::Die::die_decode($err, on_die => $disp->die2reason); + { # Decode exceptions which do not origin from Log::Report reports + ($err, my($opts, $reason, $text)) = blessed $err + ? Log::Report::Die::exception_decode($err) + : Log::Report::Die::die_decode($err, on_die => $disp->die2reason); + $disp->log($opts, $reason, __$text); } @@ -584,6 +595,7 @@ wantarray ? @ret : $ret; } +#------------ =section Abbreviations for report() The following functions are all wrappers for calls to M, diff --git a/t/42exc-dbix-class.t b/t/42exc-dbix-class.t new file mode 100755 index 0000000..865d235 --- /dev/null +++ b/t/42exc-dbix-class.t @@ -0,0 +1,102 @@ +#!/usr/bin/env perl +# Convert dbix exceptions into report + +use warnings; +use strict; + +use Log::Report; +use Log::Report::Die 'exception_decode'; +use Test::More; + +use Data::Dumper; + +$! = 3; +my $errno = $!+0; + +{ # I do not want a dependency: fake implementation of this object + package DBIx::Class::Exception; + sub new($) { bless { msg => $_[1] }, $_[0] } + use overload '""' => sub { shift->{msg} }, fallback => 1; +} +sub exception($) { DBIx::Class::Exception->new($_[0]) } + +my $dbix1 = <<__WITHOUT_STACKTRACE; +help at /tmp/a.pl line 6. +__WITHOUT_STACKTRACE + +is_deeply [ exception_decode(exception $dbix1) ] + , [ 'caught DBIx::Class::Exception' + , { location => [ $0, '/tmp/a.pl', '6', undef ] } + , 'ERROR' + , 'help' + ], 'set 1'; + +my $dbix2 = <<__WITH_STACKTRACE; +main::f(): help at /tmp/a.pl line 6. + main::f() called at /tmp/a.pl line 8 + main::g() called at /tmp/a.pl line 10 +__WITH_STACKTRACE + +is_deeply [ exception_decode(exception $dbix2) ] + , [ 'caught DBIx::Class::Exception' + , { location => [ 'main', '/tmp/a.pl', '6', 'f' ] + , stack => [ [ 'main::f', '/tmp/a.pl', '8' ] + , [ 'main::g', '/tmp/a.pl', '10' ] + ] + } + , 'PANIC' + , 'help' + ], 'set 2'; + +my $dbix3 = <<__WITHOUT_STACKTRACE; # not inside function +{UNKNOWN}: help at /tmp/a.pl line 6. +__WITHOUT_STACKTRACE + +is_deeply [ exception_decode(exception $dbix3) ] + , [ 'caught DBIx::Class::Exception' + , { location => [ $0, '/tmp/a.pl', '6', undef ] } + , 'ERROR' + , 'help' + ], 'set 3'; + +my $dbix4 = <<'__FROM_DB'; # contributed by Andrew +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 +__FROM_DB + +#warn "DBIx4:", Dumper exception_decode(exception $dbix4); + +is_deeply [ exception_decode(exception $dbix4) ] + , [ 'caught DBIx::Class::Exception' + , { location => + [ 'DBIx::Class::Storage::DBI' + , '/home/abeverley/git/Isaas/bin/../lib/Isaas/DBIC.pm' + , '18' + , '_dbh_execute' + ] } + , 'ERROR' + , 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]} + ], 'set 4'; + + +### Test automatic conversion + +try { die exception $dbix1 }; +my $exc = $@->wasFatal; +isa_ok $exc, 'Log::Report::Exception'; +is "$exc", "error: help\n"; + +my $msg = $exc->message; +isa_ok $msg, 'Log::Report::Message'; +is $msg->toString, 'help'; + + +### Test report with object + +try { error exception $dbix1 }; +my $err = $@->wasFatal; +isa_ok $err, 'Log::Report::Exception'; +is "$err", "error: help at /tmp/a.pl line 6.\n"; + +done_testing; + +1; diff --git a/t/43exc-xml-libxml.t b/t/43exc-xml-libxml.t new file mode 100755 index 0000000..201ee0a --- /dev/null +++ b/t/43exc-xml-libxml.t @@ -0,0 +1,42 @@ +#!/usr/bin/env perl +# Convert XML::LibXML exceptions into report + +use warnings; +use strict; + +use Log::Report; +use Log::Report::Die 'exception_decode'; +use Test::More; + +#use Data::Dumper; + +BEGIN { + eval 'require XML::LibXML::Error'; + plan skip_all => 'XML::LibXML::Error not available' if $@; + + eval 'require XML::LibXML'; + plan skip_all => 'Your installation of XML::LibXML is broken' if $@; +} + +# The XML::LibXML::Error object does not have a constructor, so we +# need to trigger one. +my $xml = eval { XML::LibXML->load_xml(string => \'') }; +ok ! defined $xml, 'parse broken xml'; +my $error = $@; +isa_ok $error, 'XML::LibXML::Error'; + +#warn Dumper exception_decode($error); +my @dec = exception_decode($error); +my $msg = pop @dec; +is_deeply \@dec, + , [ 'caught XML::LibXML::Error' + , { location => [ 'libxml', '', '1', 'parser' ], errno => 13077 } + , 'ERROR' + ], 'error 1'; + +# the message may vary over libxml2 versions +like $msg, qr/bad\-xml/, $msg; + +done_testing; + +1;