File Coverage

blib/lib/CLI/Osprey.pm

Criterion	Covered	Total	%
statement	82	87	94.2
branch	12	18	66.6
condition	1	3	33.3
subroutine	15	15	100.0
pod			n/a
total	110	123	89.4

package CLI::Osprey;
use strict;
use warnings;

# ABSTRACT: MooX::Options + MooX::Cmd + Sanity
our $VERSION = '0.06'; # VERSION
our $AUTHORITY = 'cpan:ARODLAND'; # AUTHORITY

use Carp 'croak';
use Module::Runtime 'use_module';
use Scalar::Util qw(reftype);

use Moo::Role qw(); # only want class methods, not setting up a role

use CLI::Osprey::InlineSubcommand ();

my @OPTIONS_ATTRIBUTES = qw(
  option option_name format short repeatable negatable spacer_before spacer_after doc long_doc format_doc order hidden
);

sub import {
  my (undef, @import_options) = @_;
  my $target = caller;

  for my $method (qw(with around has)) {
    next if $target->can($method);
    croak "Can't find the method '$method' in package '$target'. CLI::Osprey requires a Role::Tiny-compatible object system like Moo or Moose.";
  }

  my $with = $target->can('with');
  my $around = $target->can('around');
  my $has = $target->can('has');

  if ( ! Moo::Role->is_role( $target ) ) { # not in a role
    eval "package $target;\n" . q{
      sub _osprey_options {
        my $class = shift;
        return $class->maybe::next::method(@_);
      }

      sub _osprey_config {
        my $class = shift;
        return $class->maybe::next::method(@_);
      }

      sub _osprey_subcommands {
        my $class = shift;
        return $class->maybe::next::method(@_);
      }
      1;
    } || croak($@);
  }

  my $osprey_config = {
    preserve_argv => 1,
    abbreviate => 1,
    prefer_commandline => 1,
    @import_options,
  };

  $around->(_osprey_config => sub {
    my ($orig, $self) = (shift, shift);
    return $self->$orig(@_), %$osprey_config;
  });

  my $options_data = { };
  my $subcommands = { };

  my $apply_modifiers = sub {
    return if $target->can('new_with_options');
    $with->('CLI::Osprey::Role');
    $around->(_osprey_options => sub {
      my ($orig, $self) = (shift, shift);
      return $self->$orig(@_), %$options_data;
    });
    $around->(_osprey_subcommands => sub {
      my ($orig, $self) = (shift, shift);
      return $self->$orig(@_), %$subcommands;
    });
  };

  my $added_order = 0;

  my $option = sub {
    my ($name, %attributes) = @_;

    $has->($name => _non_option_attributes(%attributes));
    $options_data->{$name} = _option_attributes($name, %attributes);
    $options_data->{$name}{added_order} = ++$added_order;
    $apply_modifiers->();
  };

  my $subcommand = sub {
    my ($name, $subobject) = @_;

    if (ref($subobject) && reftype($subobject) eq 'CODE') {
      my @args = @_[2 .. $#_];
      $subobject = CLI::Osprey::InlineSubcommand->new(
        name => $name,
        method => $subobject,
        @args,
      );
    }
    else {
        use_module($subobject) unless $osprey_config->{on_demand};
    }

    $subcommands->{$name} = $subobject;
    $apply_modifiers->();
  };

  if (my $info = $Role::Tiny::INFO{$target}) {
    $info->{not_methods}{$option} = $option;
    $info->{not_methods}{$subcommand} = $subcommand;
  }

  {
    no strict 'refs';
    *{"${target}::option"} = $option;
    *{"${target}::subcommand"} = $subcommand;
  }

  $apply_modifiers->();

  return;
}

sub _non_option_attributes {
  my (%attributes) = @_;
  my %filter_out;
  @filter_out{@OPTIONS_ATTRIBUTES} = ();
  return map {
    $_ => $attributes{$_}
  } grep {
    !exists $filter_out{$_}
  } keys %attributes;
}

sub _option_attributes {
  my ($name, %attributes) = @_;

  unless (defined $attributes{option}) {
    ($attributes{option} = $name) =~ tr/_/-/;
  }
  my $ret = {};
  for (@OPTIONS_ATTRIBUTES) {
    $ret->{$_} = $attributes{$_} if exists $attributes{$_};
  }
  return $ret;
}

1;

__END__