Gecko [ www.vortexaion.com ]

Name	Size	Permission	Date
DBIC	[ DIR ]	drwxrwxrwx	2024-07-26 17:40
Dispatcher	[ DIR ]	drwxrwxrwx	2024-07-26 17:40
Minimal	[ DIR ]	drwxrwxrwx	2024-07-26 17:40
messages	[ DIR ]	drwxrwxrwx	2024-07-26 17:40
Die.pm	3.92 KB	-rw-rw-rw-	2021-01-15 17:36
Die.pod	2.56 KB	-rw-rw-rw-	2021-01-15 17:36
Dispatcher.pm	9.32 KB	-rw-rw-rw-	2021-01-15 17:36
Dispatcher.pod	13.06 KB	-rw-rw-rw-	2021-01-15 17:36
Domain.pm	4.68 KB	-rw-rw-rw-	2021-01-15 17:36
Domain.pod	9.34 KB	-rw-rw-rw-	2021-01-15 17:36
Exception.pm	2.2 KB	-rw-rw-rw-	2021-01-15 17:36
Exception.pod	3.8 KB	-rw-rw-rw-	2021-01-15 17:36
Message.pm	4.73 KB	-rw-rw-rw-	2021-01-15 17:36
Message.pod	16.72 KB	-rw-rw-rw-	2021-01-15 17:36
Minimal.pm	5.83 KB	-rw-rw-rw-	2021-01-15 11:07
Minimal.pod	2.38 KB	-rw-rw-rw-	2021-01-15 11:07
Optional.pm	1.01 KB	-rw-rw-rw-	2021-01-15 11:07
Optional.pod	1.48 KB	-rw-rw-rw-	2021-01-15 11:07
Translator.pm	930 B	-rw-rw-rw-	2021-01-15 17:36
Translator.pod	1.99 KB	-rw-rw-rw-	2021-01-15 17:36
Util.pm	6.13 KB	-rw-rw-rw-	2021-01-15 11:07
Util.pod	4 KB	-rw-rw-rw-	2021-01-15 11:07

Rename

# Copyrights 2007-2021 by [Mark Overmeer <markov@cpan.org>].
#  For other contributors see ChangeLog.
# See the manual pages for details on the licensing terms.
# Pod stripped from pm file by OODoc 2.02.
# This code is part of distribution Log-Report. Meta-POD processed with
# OODoc into POD and HTML manual-pages.  See README.md
# Copyright Mark Overmeer.  Licensed under the same terms as Perl itself.

package Log::Report::Die;
use vars '$VERSION';
$VERSION = '1.31';

use base 'Exporter';

use warnings;
use strict;

our @EXPORT = qw/die_decode exception_decode/;

use POSIX  qw/locale_h/;

sub die_decode($%)
{   my ($text, %args) = @_;

my @text   = split /\n/, $text;
    @text or return ();
    chomp $text[-1];

# Try to catch the error directly, to remove it from the error text
    my %opt    = (errno => $! + 0);
    my $err    = "$!";

my $dietxt = $text[0];
    if($text[0] =~ s/ at (.+) line (\d+)\.?$// )
    {   $opt{location} = [undef, $1, $2, undef];
    }
    elsif(@text > 1 && $text[1] =~ m/^\s*at (.+) line (\d+)\.?$/ )
    {   # sometimes people carp/confess with \n, folding the line
        $opt{location} = [undef, $1, $2, undef];
        splice @text, 1, 1;
    }

$text[0] =~ s/\s*[.:;]?\s*$err\s*$//  # the $err is translation sensitive
        or delete $opt{errno};

my @msg = shift @text;
    length $msg[0] or $msg[0] = 'stopped';

my @stack;
    foreach (@text)
    {   if(m/^\s*(.*?)\s+called at (.*?) line (\d+)\s*$/)
             { push @stack, [ $1, $2, $3 ] }
        else { push @msg, $_ }
    }
    $opt{stack}   = \@stack;
    $opt{classes} = [ 'perl', (@stack ? 'confess' : 'die') ];

my $reason
      = $opt{errno} ? 'FAULT'
      : @stack      ? 'PANIC'
      :               $args{on_die} || 'ERROR';

($dietxt, \%opt, $reason, join("\n", @msg));
}

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";