File Coverage

blib/lib/Catmandu/Error.pm

Criterion	Covered	Total	%
statement	184	184	100.0
branch	15	18	83.3
condition			n/a
subroutine	47	47	100.0
pod	0	7	0.0
total	246	256	96.0

package Catmandu::Error;

use Catmandu::Sane;

our $VERSION = '1.2020';

use Moo;
use namespace::clean;

extends 'Throwable::Error';

with 'Catmandu::Logger';

has message => (
    is     => 'lazy',
    coerce => sub {
        my $msg = $_[0] // "";
        $msg =~ s/\s+$//;
        $msg;
    }
);

sub BUILD {
    my ($self) = @_;
    my $msg = $self->log_message;
    if ($self->log->is_debug) {
        $msg .= "\n\n" . $self->stack_trace->as_string;
    }
    $self->log->error($msg);
}

sub log_message {
    $_[0]->message;
}

sub _build_message {
    "";
}

package Catmandu::Error::Source;

use Catmandu::Sane;

our $VERSION = '1.2020';

use Moo::Role;
use Catmandu::Util qw(is_string);
use namespace::clean;

has source => (is => 'rw', writer => 'set_source');

sub _source_log_message {
    my $msg = "";
    if (is_string(my $source = $_[0]->source)) {
        $msg .= "\nSource:";
        for (split(/\n/, $source)) {
            $msg .= "\n\t$_";
        }
    }
    $msg;
}

package Catmandu::BadVal;

use Catmandu::Sane;

our $VERSION = '1.2020';

use Moo;
use namespace::clean;

extends 'Catmandu::Error';

package Catmandu::BadArg;

use Catmandu::Sane;

our $VERSION = '1.2020';

use Moo;
use namespace::clean;

extends 'Catmandu::BadVal';

package Catmandu::NotImplemented;

use Catmandu::Sane;

our $VERSION = '1.2020';

use Moo;
use namespace::clean;

extends 'Catmandu::Error';

package Catmandu::NoSuchPackage;

use Catmandu::Sane;

our $VERSION = '1.2020';

use Moo;
use namespace::clean;

extends 'Catmandu::Error';

has package_name => (is => 'ro');

sub log_message {
    my ($self)   = @_;
    my $err      = $self->message;
    my $pkg_name = $self->package_name;
    my $msg      = "Failed to load $pkg_name";
    if (my ($type, $name)
        = $pkg_name =~ /^Catmandu::(Importer|Exporter|Store)::(\S+)/)
    {
        $msg
            = "Can't find the "
            . lc($type)
            . " '$name' in your configuration file or $pkg_name is not installed.";
    }
    elsif ($pkg_name =~ /^Catmandu::Fix::\S+/) {
        my ($fix_name) = $pkg_name =~ /([^:]+)$/;
        if ($fix_name =~ /^[a-z]/) {
            $msg
                = "Tried to execute the fix '$fix_name' but can't find $pkg_name on your system.";
        }
    }
    $msg .= "\nError: $err";
    $msg .= "\nPackage name: $pkg_name";
    $msg;
}

package Catmandu::FixParseError;

use Catmandu::Sane;

our $VERSION = '1.2020';

use Moo;
use namespace::clean;

extends 'Catmandu::Error';

with 'Catmandu::Error::Source';

sub log_message {
    my ($self) = @_;
    my $err    = $self->message;
    my $msg    = "Syntax error in your fixes...";
    $msg .= "\nError: $err";
    $msg .= $self->_source_log_message;
    $msg;
}

package Catmandu::NoSuchFixPackage;

use Catmandu::Sane;

our $VERSION = '1.2020';

use Moo;
use namespace::clean;

extends 'Catmandu::NoSuchPackage';

with 'Catmandu::Error::Source';

has fix_name => (is => 'ro');

around log_message => sub {
    my ($orig, $self) = @_;
    my $fix_name = $self->fix_name;
    my $msg      = $orig->($self);
    $msg .= "\nFix name: $fix_name" if $fix_name;
    $msg .= $self->_source_log_message;
    $msg;
};

package Catmandu::BadFixArg;

use Catmandu::Sane;

our $VERSION = '1.2020';

use Moo;
use namespace::clean;

extends 'Catmandu::BadArg';

with 'Catmandu::Error::Source';

has package_name => (is => 'ro');
has fix_name     => (is => 'ro');

sub log_message {
    my ($self)   = @_;
    my $err      = $self->message;
    my $fix_name = $self->fix_name;
    my $msg
        = "The fix '$fix_name' was called with missing or wrong arguments.";
    $msg .= "\nError: $err";
    $msg .= $self->_source_log_message;
    $msg;
}

package Catmandu::FixError;

use Catmandu::Sane;

our $VERSION = '1.2020';

use Moo;
use Data::Dumper;
use namespace::clean;

extends 'Catmandu::Error';

has data => (is => 'ro');
has fix  => (is => 'ro');

sub log_message {
    my ($self) = @_;
    my $err    = $self->message;
    my $fix    = $self->fix;
    my $data   = $self->data;
    my $msg    = "One of your fixes threw an error...";
    $msg .= "\nError: $err";
    $msg .= "\nSource: $fix" if $fix;
    $msg .= "\nInput:\n" . Dumper($data) if defined $data;
    $msg;
}

package Catmandu::HTTPError;

use Catmandu::Sane;

our $VERSION = '1.2020';

use Moo;
use Data::Dumper;
use namespace::clean;

# avoid circular dependencies
require Catmandu::Util;

extends 'Catmandu::Error';

has code             => (is => 'ro');
has url              => (is => 'ro');
has method           => (is => 'ro');
has request_headers  => (is => 'ro');
has request_body     => (is => 'ro');
has response_headers => (is => 'ro');
has response_body    => (is => 'ro');

sub log_message {
    my ($self)           = @_;
    my $err              = $self->message;
    my $code             = $self->code;
    my $url              = $self->url;
    my $method           = $self->method;
    my $request_body     = $self->request_body;
    my $response_body    = $self->response_body;
    my $request_headers  = $self->request_headers;
    my $response_headers = $self->response_headers;
    my $msg              = "Got a HTTP error...";
    $msg .= "\nError: $err";
    $msg .= "\nCode: $code";
    $msg .= "\nURL: $url";
    $msg .= "\nMethod: $method";
    $msg .= "\nRequest headers: "
        . $self->_headers_to_string($request_headers);

    if (Catmandu::Util::is_string($request_body)) {
        $msg .= "\nRequest body: \n" . $self->_indent($request_body);
    }
    $msg .= "\nResponse headers: "
        . $self->_headers_to_string($response_headers);
    if (Catmandu::Util::is_string($response_body)) {
        $msg .= "\nResponse body: \n" . $self->_indent($response_body);
    }
    $msg;
}

sub _headers_to_string {
    my ($self, $headers) = @_;
    my $str = "";
    for (my $i = 0; $i < @$headers; $i++) {
        $str .= "\n\t" . $headers->[$i++] . ": " . $headers->[$i];
    }
    $str;
}

sub _indent {
    my ($self, $str) = @_;
    $str =~ s/([^\r\n]+)/\t$1/g;
    $str;
}

1;

__END__

=pod

=head1 NAME

Catmandu::Error - Catmandu error hierarchy

=head1 SYNOPSIS

    use Catmandu::Sane;

    sub be_naughty {
        Catmandu::BadArg->throw("very naughty") if shift;
    }

    try {
        be_naughty(1);
    } catch_case [
        'Catmandu::BadArg' => sub {
            say "sorry";
        }
    ];

=head1 CURRRENT ERROR HIERARCHY
    Throwable::Error
        Catmandu::Error
            Catmandu::BadVal
                Catmandu::BadArg
                    Catmandu::BadFixArg
            Catmandu::NotImplemented
            Catmandu::NoSuchPackage
                Catmandu::NoSuchFixPackage
            Catmandu::FixParseError
            Catmandu::FixError
            Catmandu::HTTPError

=head1 SEE ALSO

L<Throwable>

=cut