File Coverage

blib/lib/Circle/Command.pm

Criterion	Covered	Total	%
statement	9	61	14.7
branch	0	8	0.0
condition	0	23	0.0
subroutine	3	16	18.7
pod	0	12	0.0
total	12	120	10.0

#  You may distribute under the terms of the GNU General Public License
#
#  (C) Paul Evans, 2008-2014 -- [e-mail]

package Circle::Command;

use strict;
use warnings;

use Attribute::Storage qw( get_subattrs get_subattr find_subs_with_attr );
require mro;

sub _find_commands
{
   my ( $obj, $cinv, $containedby ) = @_;

   my @ret;
   my %commands;

   while( $obj ) {
      my %subs = find_subs_with_attr( mro::get_linear_isa( ref $obj ), "Command_description",
         matching => qr/^command_/,
      );

      foreach my $name ( keys %subs ) {
         ( my $commandname = $name ) =~ s/^command_//;
         my $cv = $subs{$name};

         next if $commands{$commandname};

         my $subof = get_subattr( $cv, "Command_subof" );
         next if  $containedby and !$subof or
                 !$containedby and  $subof or
                  $containedby and $subof and $containedby ne $subof;

         my $attrs = get_subattrs( $cv );

         $commands{$commandname} = 1;
         push @ret, __PACKAGE__->new( %$attrs,
            name => $commandname,
            obj  => $obj,
            cv   => $cv,
         );
      }

      # Collect in parent too
      $obj = $obj->can( "commandable_parent" ) && $obj->commandable_parent( $cinv );
   }

   return @ret;
}

sub root_commands
{
   my $class = shift;
   my ( $cinv ) = @_;

   return map { $_->name => $_ } _find_commands( $cinv->invocant, $cinv, undef );
}

# Object stuff

sub new
{
   my $class = shift;
   my %attrs = @_;

   $attrs{name} =~ s/_/ /g;

   return bless \%attrs, $class;
}

sub sub_commands
{
   my $self = shift;
   my ( $cinv ) = @_;

   return map { $_->shortname => $_ } _find_commands( $cinv->invocant, $cinv, $self->name );
}

sub name
{
   my $self = shift; return $self->{name};
}

sub shortname
{
   my $self = shift;
   ( split m/ /, $self->name )[-1];
}

sub is_default
{
   my $self = shift; return $self->{Command_default};
}

sub desc
{
   my $self = shift; return $self->{Command_description}[0] || "[no description]";
}

sub detail
{
   my $self = shift; return $self->{Command_description}[1];
}

sub args
{
   my $self = shift;
   return unless $self->{Command_arg};
   return @{ $self->{Command_arg} };
}

sub opts
{
   my $self = shift;
   return $self->{Command_opt};
}

sub default_sub
{
   my $self = shift;
   my ( $cinv ) = @_;

   my %subs = $self->sub_commands( $cinv );
   my @defaults = grep { $_->is_default } values %subs;

   return $defaults[0] if @defaults == 1; # Only if it's unique
   return;
}

sub invoke
{
   my $self = shift; $self->{cv}->( $self->{obj}, @_ );
}

0x55AA;