File Coverage

blib/lib/Circle/Commandable.pm

Criterion	Covered	Total	%
statement	129	202	63.8
branch	33	94	35.1
condition	8	21	38.1
subroutine	22	23	95.6
pod	0	9	0.0
total	192	349	55.0

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

package Circle::Commandable;

use strict;
use warnings;

use Carp;

use Attribute::Storage 0.06 qw( get_subattr get_subattrs );

use Circle::Command;
use Circle::CommandInvocation;

use Circle::Widget::Entry;

#############################################
### Attribute handlers for command_* subs ###
#############################################

sub Command_description :ATTR(CODE)
{
   my $class = shift;
   my ( $text ) = @_;

   my ( $brief, $detail ) = split( m/\n/, $text, 2 );

   return [ $brief, $detail ];
}

sub Command_arg :ATTR(CODE,MULTI)
{
   my $class = shift;
   my ( $args, $name, %spec ) = @_;

   # Some things are only allowed on the last argument. Check none of these
   # apply to the previous one
   my $prev = $args ? $args->[-1] : undef;

   if( $prev ) {
      $prev->{eatall}  and croak "Cannot have another argument after an eatall";
      $prev->{collect} and croak "Cannot have another argument after a collect";
      $prev->{trail}   and croak "Cannot have another argument after a trail";
   }

   my $optional = $name =~ s/\?$//; # No error if this is missing

   my %arg = (
      name     => uc $name,
      optional => $optional,
      eatall   => delete $spec{eatall},  # This argument consumes all the remaining text in one string
      collect  => delete $spec{collect}, # This argument collects all the non-option tokens in an ARRAY ref
   );

   $arg{eatall} and $arg{collect} and croak "Cannot eatall and collect";

   keys %spec and croak "Unrecognised argument specification keys: ".join( ", ", keys %spec );

   my $trail = 0;
   if( $name eq "..." ) {
      $arg{trail} = 1;
   }
   else {
      $name =~ m/\W/ and croak "Cannot use $name as an argument name";
   }

   push @$args, \%arg;

   return $args;
}

sub Command_opt :ATTR(CODE,MULTI)
{
   my $class = shift;
   my ( $opts, $name, %spec ) = @_;

   my %opt = (
      desc => delete $spec{desc},
   );

   keys %spec and croak "Unrecognised option specification keys: ".join( ", ", keys %spec );

   $name =~ s/=(.*)$// or croak "Cannot recognise $name as an option spec";
   $opt{type} = $1;

   $opt{type} =~ m/^[\$\+]$/ or croak "Cannot recognise $opt{type} as an option type";

   $opts->{$name} = \%opt;

   return $opts;
}

sub Command_subof :ATTR(CODE)
{
   my $class = shift;
   my ( $parent ) = @_;

   return $parent;
}

sub Command_default :ATTR(CODE)
{
   return 1; # Just a boolean
}

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

   my $cmd = $cinv->pull_token;

   my $command = undef;
   my %commands = Circle::Command->root_commands( $cinv );

   while( keys %commands and $cmd ||= $cinv->pull_token ) {
      unless( exists $commands{$cmd} ) {
         $cinv->responderr( $command ? $command->name . " has no sub command $cmd"
                                     : "No such command $cmd" );
         return;
      }

      $command = $commands{$cmd};
      %commands = $command->sub_commands( $cinv );

      undef $cmd;
   }

   while( keys %commands ) {
      my $subcmd = $command->default_sub( $cinv );

      if( !$subcmd ) {
         # No default subcommand - issue help on $command instead
         my $helpinv = $cinv->nest( "help " . $command->name );
         return $self->do_command( $helpinv );
      }

      $command = $subcmd;
      %commands = $command->sub_commands( $cinv );
   }

   my $cname = $command->name;

   my @args;
   my %opts;

   my @argspec = $command->args;
   my $optspec = $command->opts;

   my $argindex = 0;

   while( length $cinv->peek_remaining ) {
      if( $cinv->peek_remaining =~ m/^-/ ) {
         # An option
         my $optname = $cinv->pull_token;
         $optname =~ s/^-//;

         $optspec and exists $optspec->{$optname} or
            return $cinv->responderr( "$cname: unrecognised option $optname" );

         my $optvalue;

         if( $optspec->{$optname}{type} eq '$' ) {
            $optvalue = $cinv->pull_token;
            defined $optvalue or
               return $cinv->responderr( "$cname: option $optname require a value" );
         }
         else {
            $optvalue = 1;
         }

         $opts{$optname} = $optvalue;
      }
      else {
         return $cinv->responderr( "$cname: Too many arguments" ) if !@argspec or $argindex >= @argspec;

         my $a = $argspec[$argindex];

         if( $a->{eatall} ) {
            push @args, $cinv->peek_remaining;
            $argindex++;
            last;
         }
         elsif( $a->{collect} ) {
            # If this is the first one, $args[-1] won't be an ARRAY ref
            push @args, [] unless ref $args[-1];
            push @{ $args[-1] }, $cinv->pull_token;
         }
         elsif( $a->{trail} ) {
            last;
         }
         else {
            push @args, $cinv->pull_token;
            $argindex++;
         }
      }
   }

   while( $argindex < @argspec ) {
      my $a = $argspec[$argindex++];

      if( $a->{collect} ) {
         push @args, [] unless ref $args[-1];
         last;
      }
      elsif( $a->{trail} ) {
         last;
      }

      $a->{optional} or
         return $cinv->responderr( "$cname: expected $a->{name}" );

      push @args, undef;
   }

   push @args, \%opts if $optspec;

   push @args, $cinv;

   my @response = eval { $command->invoke( @args ) };
   if( $@ ) {
      my $text = $@; chomp $text;
      $cinv->responderr( $text );
   }
   else {
      $cinv->respond( $_ ) foreach @response;
   }
}

sub command_help
   : Command_description("Display help on a command")
   : Command_arg('command?')
   : Command_arg('...')
{
   my $self = shift;
   my ( $cmd, $cinv ) = @_;

   my $command = undef;
   my %commands = Circle::Command->root_commands( $cinv );

   if( !defined $cmd ) {
      my $class = ref $self || $self;
      $cinv->respond( "Available commands for $class:" );
   }

   while( ( $cmd ||= $cinv->pull_token ) ) {
      unless( exists $commands{$cmd} ) {
         $cinv->responderr( $command ? $command->name . " has no sub command $cmd"
                                     : "No such command $cmd" );
         return;
      }

      $command = $commands{$cmd};
      %commands = $command->sub_commands( $cinv );

      undef $cmd;
   }

   if( $command ) {
      $cinv->respond( "/" . $command->name . " - " . $command->desc );
   }

   if( keys %commands ) {
      $cinv->respond( "Usage: " . $command->name . " SUBCMD ..." ) if $command;

      my @table;
      foreach my $sub ( map { $commands{$_} } sort keys %commands ) {
         my $subname;
         # bold function name if it's default
         if( $sub->is_default ) {
            $subname = Circle::TaggedString->new( " /" . $sub->name );
            $subname->apply_tag( 0, $subname->length, b => 1 );
         }
         else {
            $subname = " /" . $sub->name;
         }

         push @table, [ $subname, $sub->desc ];
      }

      $cinv->respond_table( \@table, colsep => " - ", headings => [ "Command", "Description" ] );

      return;
   }

   my @argdesc;
   foreach my $a ( $command->args ) {
      my $name = $a->{name};
      $name .= "..."    if $a->{eatall};
      $name .= "+"      if $a->{collect};
      $name = "[$name]" if $a->{optional};
      push @argdesc, $name;
   }

   $cinv->respond( "Usage: " . join( " ", $command->name, @argdesc ) );

   if( my $opts = $command->opts ) {
      $cinv->respond( "Options:" );

      my @table;

      foreach my $opt ( sort keys %$opts ) {
         my $opttype = $opts->{$opt}{type};
         my $desc = defined $opts->{$opt}{desc} ? $opts->{$opt}{desc} : "";

         push @table, [ "  -$opt" . ( $opttype eq '$' ? " VALUE" : "" ), $desc ];
      }

      $cinv->respond_table( \@table, headings => [ "Option", "Description" ] );
   }

   if( my $detail = $command->detail ) {
      $cinv->respond( "" );
      $cinv->respond( $_ ) for split( m/\n/, $detail );
   }

   return;
}

sub method_do_command
{
   my $self = shift;
   my ( $ctx, $command ) = @_;

   my $cinv = Circle::CommandInvocation->new( $command, $ctx->stream, $self );
   $self->do_command( $cinv );
}

###
# Widget
###

sub get_widget_commandentry
{
   my $self = shift;

   return $self->{widget_commandentry} if defined $self->{widget_commandentry};

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

   my $widget = $registry->construct(
      "Circle::Widget::Entry",
      autoclear => 1,
      focussed => 1,
      history => 100, # TODO
      on_enter => sub {
         my ( $text, $ctx ) = @_;

         if( $text =~ m{^/} ) {
            substr( $text, 0, 1 ) = "";

            my $cinv = Circle::CommandInvocation->new( $text, $ctx->stream, $self );
            $self->do_command( $cinv );
         }
         elsif( $self->can( "enter_text" ) ) {
            $self->enter_text( $text );
         }
         else {
            $self->responderr( "Cannot enter raw text here" );
         }
      },
   );

   return $self->{widget_commandentry} = $widget;
}

0x55AA;