libcatmandu-perl 1.0700-1 / usr / share / perl5 / Catmandu / CLI.pm

package Catmandu::CLI;

use Catmandu::Sane;

our $VERSION = '1.07';

use Catmandu::Util qw(is_instance is_able is_string);
use Catmandu;
use Log::Any::Adapter;
use Data::Dumper;

use parent qw(App::Cmd);

sub deleted_commands {
    [
        qw(
            Catmandu::Cmd::data
            Catmandu::Cmd::exporter_info
            Catmandu::Cmd::fix_info
            Catmandu::Cmd::importer_info
            Catmandu::Cmd::module_info
            Catmandu::Cmd::move
            Catmandu::Cmd::store_info
            )
    ];
}

sub default_command {'commands'}

sub plugin_search_path {'Catmandu::Cmd'}

sub global_opt_spec {
    (['debug|D:i', ""], ['load_path|L=s@', ""], ['lib_path|I=s@', ""]);
}

sub default_log4perl_config {
    my $level    = shift // 'DEBUG';
    my $appender = shift // 'STDERR';

    my $config = <<EOF;
log4perl.category.Catmandu=$level,$appender
log4perl.category.Catmandu::Fix::log=TRACE,$appender

log4perl.appender.STDOUT=Log::Log4perl::Appender::Screen
log4perl.appender.STDOUT.stderr=0
log4perl.appender.STDOUT.utf8=1

log4perl.appender.STDOUT.layout=PatternLayout
log4perl.appender.STDOUT.layout.ConversionPattern=%d [%P] - %p %l %M time=%r : %m%n

log4perl.appender.STDERR=Log::Log4perl::Appender::Screen
log4perl.appender.STDERR.stderr=1
log4perl.appender.STDERR.utf8=1

log4perl.appender.STDERR.layout=PatternLayout
log4perl.appender.STDERR.layout.ConversionPattern=%d [%P] - %l : %m%n

EOF
    \$config;
}

sub setup_debugging {
    my %LEVELS = (1 => 'WARN', 2 => 'INFO', 3 => 'DEBUG');
    my $debug  = shift;
    my $level  = $LEVELS{$debug} // 'WARN';
    my $load_from;

    try {
        my $log4perl_pkg = Catmandu::Util::require_package('Log::Log4perl');
        my $logany_adapter
            = Catmandu::Util::require_package('Log::Any::Adapter::Log4perl');
        my $config = Catmandu->config->{log4perl};

        if (defined $config) {
            if ($config =~ /^\S+$/) {
                Log::Log4perl::init($config);
                $load_from = "file: $config";
            }
            else {
                Log::Log4perl::init(\$config);
                $load_from = "string: <defined in catmandu.yml>";
            }
        }
        else {
            Log::Log4perl::init(default_log4perl_config($level, 'STDERR'));
            $load_from = "string: <defined in " . __PACKAGE__ . ">";
        }

        Log::Any::Adapter->set('Log4perl');
    }
    catch {
        print STDERR <<EOF;

Oops! Debugging tools not available on this platform

Try to install Log::Log4perl and Log::Any::Adapter::Log4perl

Hint: cpan Log::Log4perl Log::Any::Adapter::Log4perl
EOF
        exit(2);
    };

    Catmandu->log->warn(
        "debug activated - level $level - config load from $load_from");
}

# overload run to read the global options before
# the App::Cmd object is created
sub run {
    my ($class) = @_;

    my ($global_opts, $argv)
        = $class->_process_args([@ARGV],
        $class->_global_option_processing_params);

    my $load_path = $global_opts->{load_path} || [];
    my $lib_path  = $global_opts->{lib_path}  || [];

    if (exists $global_opts->{debug}) {
        setup_debugging($global_opts->{debug} // 1);
    }

    if (@$lib_path) {
        Catmandu::Util::use_lib(@$lib_path);
    }

    Catmandu->load(@$load_path);

    my $self = ref $class ? $class : $class->new;
    $self->set_global_options($global_opts);
    my ($cmd, $opts, @args) = $self->prepare_command(@$argv);

    try {
        $self->execute_command($cmd, $opts, @args);
    }
    catch {
        if (is_instance $_, 'Catmandu::NoSuchPackage') {
            my $pkg_name = $_->package_name;

            if ($pkg_name eq 'Catmandu::Importer::help') {
                say STDERR "Oops! Did you mean 'catmandu $ARGV[1] $ARGV[0]'?";
            }
            elsif (my ($type, $name)
                = $pkg_name =~ /^Catmandu::(Importer|Exporter|Store)::(\S+)/)
            {
                say STDERR "Oops! 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]/) {
                    say STDERR
                        "Oops! Tried to execute the fix '$fix_name' but can't find $pkg_name on your system.";
                }
                else {    # not a fix
                    say STDERR "Oops! Failed to load $pkg_name";
                }
            }
            else {
                say STDERR "Oops! Failed to load $pkg_name";
            }

            if (is_able $_, 'source') {
                $self->print_source($_->source);
            }

            goto ERROR;
        }
        elsif (is_instance $_, 'Catmandu::BadFixArg') {
            my $fix_name = $_->fix_name;
            my $source   = $_->source;
            say STDERR
                "Oops! The fix '$fix_name' was called with missing or wrong arguments.";
            $self->print_source($_->source);
        }
        elsif (is_instance $_, 'Catmandu::FixParseError') {
            my $message = $_->message;

            say STDERR "Oops! Syntax error in your fixes...";
            say STDERR "\n\t$message\n";
            $self->print_source($_->source);

            goto ERROR;
        }
        elsif (is_instance $_, 'Catmandu::FixError') {
            my $message = $_->message;
            my $data    = $_->data;
            my $fix     = $_->fix;

            say STDERR "Oops! One of your fixes threw an error...";
            say STDERR "Source: " . $_->fix;
            say STDERR "Error: $message";

            say STDERR "Input:\n" . Dumper($data) if defined $data;

            goto ERROR;
        }
        elsif (is_instance $_, 'Catmandu::HTTPError') {
            my $message       = $_->message;
            my $code          = $_->code;
            my $url           = $_->url;
            my $method        = $_->method;
            my $request_body  = $_->request_body;
            my $response_body = $_->response_body;

            say STDERR "Oops! Got a HTTP error...";
            say STDERR "Code: $code";
            say STDERR "Error: $message";
            say STDERR "URL: $url";
            say STDERR "Method: $method";
            say STDERR "Request headers:\n" . Dumper($_->request_headers);
            say STDERR "Request body:\n$request_body"
                if is_string $request_body;
            say STDERR "Response headers:\n" . Dumper($_->response_headers);
            say STDERR "Response body:\n$response_body"
                if is_string $response_body;

            goto ERROR;
        }
        else {
            say STDERR "Oops! $_";

            goto ERROR;
        }
    };

    return 1;

ERROR:
    return undef;
}

sub print_source {
    my ($self, $source) = @_;
    if (is_string $source) {
        say STDERR "Source:\n";
        for (split(/\n/, $source)) {
            print STDERR "\t$_\n";
        }
    }
}

sub should_ignore {
    my ($self, $cmd_class) = @_;
    for my $cmd (@{$self->deleted_commands}) {
        return 1 if $cmd_class->isa($cmd);
    }
    return;
}

1;

__END__

=pod

=head1 NAME

Catmandu::CLI - The App::Cmd application class for the catmandu command line script

=head1 SEE ALSO

L<catmandu>

=cut