File Coverage

blib/lib/App/Run.pm

Criterion	Covered	Total	%
statement	145	164	88.4
branch	35	48	72.9
condition	19	51	37.2
subroutine	29	34	85.2
pod	11	11	100.0
total	239	308	77.6

package App::Run;
{
  $App::Run::VERSION = '0.03';
}
#ABSTRACT: Create simple (command line) applications

use strict;
use warnings;
use v5.10;

use Carp;
use Try::Tiny;
use Clone qw(clone);
use Scalar::Util qw(reftype blessed);
use Log::Contextual::WarnLogger;
use Log::Contextual qw(:log :Dlog with_logger set_logger), -default_logger =>
    Log::Contextual::WarnLogger->new({ env_prefix => 'APP_RUN' });
use Log::Log4perl qw();
use File::Basename qw();
use Config::Any;

our $CALLPKG;

sub import {
    my $pkg = shift;
    $CALLPKG = caller(0);

    no strict 'refs';
    if (@_ and $_[0] eq 'script') {
      my $app;
        my $run = sub {
            my $opts = shift;
            *{"${CALLPKG}::OPTS"} = \$opts;
            @ARGV = @_;
#         set_logger $app->logger;
        };
#      foreach my $name (qw(log_error)) {
#         *{"${CALLPKG}::$name"} = \*{ $name };
#      }
      $app = App::Run->new($run);
      $app->run_with_args(@ARGV);
   }
   # TODO: require_version
}


sub new {
    my $self = bless { }, shift;

    $self->app( shift );
    $self->{options} = { @_ };

    $self;
}


sub parse_options {
    my $self = shift;

    local @ARGV = @_;

    require Getopt::Long;
    my $parser = Getopt::Long::Parser->new(
        config => [ "no_ignore_case", "pass_through" ],
    );

    my $options = $self->{options};

    my ($help,$version);
    $parser->getoptions(
        "h|?|help"   => \$help,
        "v|version"  => \$version,
        "q|quiet"    => sub { $options->{loglevel} = 'ERROR' },
        "c|config=s" => sub { $options->{config} = $_[1] },
    );

    if ($help) {
        require Pod::Usage;
        Pod::Usage::pod2usage(0);
    }

    if ($version) {
        say $self->name." ".($self->version // '(unknown version)');
        exit;
    }

    my @args;
    while (defined(my $arg = shift @ARGV)) {
        if ($arg =~ /^([^=]+)=(.+)/) {
            my @path = split /\./, $1;
            my $hash = $options;
            while( @path > 1 ) {
                my $e = shift @path;
                $hash->{$e} //= { };
                $hash = $hash->{$e};
            }
            $hash->{ $path[0] } = $2
                if (reftype($hash)||'') eq 'HASH';
        } else {
            push @args, $arg;
        }
    }

    $options->{config} = ''
        unless exists $options->{config};

    return @args;
}


sub load_config {
    my ($self, $from) = @_;

    # TODO: log this by using a default logger

    my ($config,$configfile);
    try {
        if ($from) {
            # Config::Any interface sucks
            $config = Config::Any->load_files( {
                files => [$from], use_ext => 1,
                flatten_to_hash => 1,
            } );
        } else {
            $config = Config::Any->load_stems( {
                stems => [$self->name],
                use_ext => 1,
                flatten_to_hash => 1,
            } );
        }
        ($configfile,$config) = %$config;
    } catch {
        $_ //= ''; # where's our error message?!
        croak sprintf("failed to load config file %s: $_",
            ($from || $self->name.".*"));
    };

    if ($config) {
        while (my ($key,$value) = each %$config) {
            $self->{options}->{$key} //= $value;
        }
    }
}


sub init {
    my $self = shift;

    # TODO: also set options with this method?

    $self->enable_logger;

    my $app = $self->app;
    if (blessed $app and $app->can('init')) {
        with_logger $self->logger, sub { $app->init( $self->{options} ) };
    }
}


sub run {
    my $self = shift;

    my $options = clone($self->{options});
    my $config = delete $options->{config};

    # called only the first time
    if ( defined $config ) {
        $self->load_config( $config );
        $self->init;
    }

    # override options
    if (@_ and (reftype($_[0])//'') eq 'HASH') {
        # TODO: use Data::Iterator to merge options (?)
        my $curopt = shift;
        while(my ($k,$v) = each %$curopt) {
            $options->{$k} = $v;
        }
    }

    my @args = @_;
    log_trace { "run with args: ",join(',',@args) };

    $self->enable_logger unless $self->logger;

    my $app = $self->app;

    with_logger $self->logger, sub {
#        Dlog_trace { "run $_" } $cmd, @args;
        try {
            return( (reftype $app eq 'CODE')
                ? $app->( $options, @args )
                : $app->run( $options, @args ) );
        } catch {
            log_error { $_ };
            return undef;
        }
    };
}


sub run_with_args {
    my $self = shift;
    $self->run( $self->parse_options( @_ ) );
}


sub name {
    my $self = shift;
    my $app = $self->app;

    $self->{name} //= $app->name
        if blessed $app and $app->can('name');

    ($self->{name}) = File::Basename::fileparse($0)
        unless defined $self->{name};

    return $self->{name};
}


sub version {
    my $self = shift;

    my $pkg = blessed $self->app;
    if (!$pkg) {
        $pkg = $CALLPKG;
    } elsif( $self->app->can('VERSION') ) {
        return $self->app->VERSION;
    }

    no strict 'refs';
    return ${"${pkg}::VERSION"};
}


sub app {
    my $self = shift;

    if (@_) {
        my $app = shift;
        croak 'app must be code reference or object with ->run'
            unless (reftype($app) // '') eq 'CODE'
                or (blessed $app and $app->can('run'));
        $self->{app} = $app;
    }

    return $self->{app};
}


sub logger {
    my $self = shift;
    return $self->{log4perl} unless @_;

    if (blessed($_[0]) and $_[0]->isa('Log::Log4perl::Logger')) {
        return ($self->{log4perl} = $_[0]);
    }

    croak "logger configuration must be an array reference"
        unless !$_[0] or (reftype($_[0]) || '') eq 'ARRAY';

    my @config = $_[0] ? @{$_[0]} : ({
        class     => 'Log::Log4perl::Appender::Screen',
        threshold => 'WARN'
    });

    my $log = Log::Log4perl->get_logger( __PACKAGE__ );
    foreach my $c (@config) {
        my $app = Log::Log4perl::Appender->new( $c->{class}, %$c );
        my $layout = Log::Log4perl::Layout::PatternLayout->new(
            $c->{layout} || "%d{yyyy-mm-ddTHH::mm} %p{1} %c: %m{chomp}%n" );
        $app->layout( $layout);
        $app->threshold( $c->{threshold} ) if exists $c->{threshold};
        $log->add_appender($app);
    }

    $log->trace( "new logger initialized" );

    return ($self->{log4perl} = $log);
}


sub enable_logger {
    my $self = shift;
    my $options = $self->{options};

    $self->logger( $options->{logger} );
    $self->logger->level( $options->{loglevel} || 'WARN' );
}

1;

__END__