port over the basic structure from Bot::Games

9 files changed, 537 insertions, 0 deletions

diff --git a/lib/IM/Engine/Plugin/Commands.pm b/lib/IM/Engine/Plugin/Commands.pm
index 439861b..9a59210 100644
--- a/lib/IM/Engine/Plugin/Commands.pm
+++ b/lib/IM/Engine/Plugin/Commands.pm
@@ -1,5 +1,8 @@
 package IM::Engine::Plugin::Commands;
 use Moose;
+use Module::Pluggable sub_name => 'commands';
+use List::Util qw(first);
+extends 'IM::Engine::Plugin';
 
 =head1 NAME
 
@@ -13,6 +16,192 @@ IM::Engine::Plugin::Commands -
 
 =cut
 
+has namespace => (
+    is       => 'ro',
+    isa      => 'Str',
+    required => 1,
+    trigger  => sub {
+        my $self = shift;
+        my ($path) = @_;
+        $self->search_path(new => $path);
+    },
+);
+
+has exclude_commands => (
+    is      => 'ro',
+    isa     => 'Str|RegexpRef|ArrayRef[Str|RegexpRef]',
+    trigger => sub {
+        my $self = shift;
+        my ($except) = @_;
+        $self->except($except);
+    },
+);
+
+has only_commands => (
+    is  => 'ro',
+    isa => 'Str|RegexpRef|ArrayRef[Str|RegexpRef]',
+    trigger => sub {
+        my $self = shift;
+        my ($only) = @_;
+        $self->only($only);
+    },
+);
+
+has prefix => (
+    is      => 'ro',
+    isa     => 'Str',
+    default => '!',
+);
+
+# XXX: use mxah here
+has alias => (
+    is      => 'ro',
+    isa     => 'HashRef[Str]',
+    default => sub { {} },
+);
+
+# XXX: and here
+has _active_commands => (
+    is       => 'ro',
+    isa      => 'HashRef[IM::Engine::Plugin::Commands::Command]',
+    init_arg => undef,
+    default  => sub { {} },
+);
+
+has _last_message => (
+    is       => 'rw',
+    isa      => 'IM::Engine::Incoming',
+    init_arg => undef,
+);
+
+sub BUILD {
+    my $self = shift;
+    confess "Don't specify an incoming_callback when using " . __PACKAGE__
+        if $self->engine->interface->has_incoming_callback;
+    $self->engine->interface->incoming_callback(
+        sub { $self->incoming(@_) }
+    );
+}
+
+sub incoming {
+    my $self = shift;
+    my ($message) = @_;
+    $self->_last_message($message);
+    my $text = $message->plaintext;
+    my $sender = $message->sender->name;
+    my $prefix = $self->prefix;
+
+    # XXX: rewrite this in terms of Path::Dispatcher
+    return unless $text =~ /^\Q$prefix\E(\w+)(?:\s+(.*))?/;
+    my ($command_name, $action) = (lc($1), $2);
+
+    if ($command_name eq 'cmdlist') { # XXX: make this configurable
+        $self->say(join ' ', map { $self->prefix . $_} $self->command_list);
+        return;
+    }
+
+    if ($command_name eq 'help') {
+        $command_name = $action;
+        $command_name =~ s/^-//;
+        $action = '-help';
+    }
+
+    $command_name = $self->_find_command($command_name);
+    return unless $command_name;
+
+    my $command = $self->_active_commands->{$command_name};
+    if (!defined $command) {
+        my $command_package = $self->_command_package($command_name);
+        eval { Class::MOP::load_class($command_package) };
+        if ($@) {
+            warn $@;
+            $self->say((split /\n/, $@)[0]);
+            return;
+        }
+        $command = $command_package->new(_ime_plugin => $self);
+        $self->_active_commands->{$command_name} = $command;
+    }
+
+    # XXX: commands need to be able to print stuff on their own too
+    #$command->say_cb($args{say_cb});
+
+    if (!$self->_active_commands->{$command_name}->is_active
+     && (!defined($action) || $action !~ /^-/)) {
+        $self->say($command->init($sender)) if $command->can('init');
+        $self->_active_commands->{$command_name}->is_active(1);
+    }
+
+    return unless defined $action;
+
+    if ($action =~ /^-(\w+)\s*(.*)/) {
+        my ($action, $arg) = ($1, $2);
+        if (my $method_meta = $command->meta->get_command($action)) {
+            if ($method_meta->needs_init
+             && !$self->_active_commands->{$command_name}->is_active) {
+                $self->say("$command_name isn't active yet!");
+                return;
+            }
+            my $body = $method_meta->execute($command, $arg,
+                                             {player => $sender});
+            my @extra_args = $method_meta->meta->does_role('IM::Engine::Plugin::Commands::Trait::Method::Formatted') ? (formatter => $method_meta->formatter) : ();
+            $self->say($body, @extra_args);
+        }
+        else {
+            $self->say("Unknown command $action for command $command_name");
+            return;
+        }
+    }
+    else {
+        # XXX: need better handling for "0", but B::BB doesn't currently
+        # handle that properly either, so
+        # also, this should probably be factored into $say, i think?
+        $self->say($command->default($sender, $action));
+    }
+
+    if (!$command->is_active) {
+        delete $self->_active_commands->{$command_name};
+    }
+
+    return;
+}
+
+sub say {
+    my $self = shift;
+    my ($message, %args) = @_;
+    $message = $args{formatter}->($message) if exists $args{formatter};
+    $self->engine->send_message($self->_last_message->reply($message));
+}
+
+sub command_list {
+    my $self = shift;
+    my $namespace = $self->namespace;
+    return sort map { s/\Q${namespace}:://; lc } $self->commands;
+}
+
+sub is_command {
+    my $self = shift;
+    my ($name) = @_;
+    return (grep { $name eq $_ } $self->command_list) ? 1 : 0;
+}
+
+sub _command_package {
+    my $self = shift;
+    my ($name) = @_;
+    return first { /\Q::$name\E$/i } $self->commands;
+}
+
+sub _find_command {
+    my $self = shift;
+    my ($abbrev) = @_;
+    return $abbrev if $self->is_command($abbrev);
+    return $self->alias->{$abbrev}
+        if exists $self->alias->{$abbrev}
+        && $self->is_command($self->alias->{$abbrev});
+    my @possibilities = grep { /^\Q$abbrev/ } $self->command_list;
+    return $possibilities[0] if @possibilities == 1;
+    return;
+}
+
 __PACKAGE__->meta->make_immutable;
 no Moose;
 
diff --git a/lib/IM/Engine/Plugin/Commands/Command.pm b/lib/IM/Engine/Plugin/Commands/Command.pm
new file mode 100644
index 0000000..5b6b46d
--- /dev/null
+++ b/lib/IM/Engine/Plugin/Commands/Command.pm
@@ -0,0 +1,53 @@
+package IM::Engine::Plugin::Commands::Command;
+use IM::Engine::Plugin::Commands::OO;
+
+has help => (
+    is         => 'ro',
+    isa        => 'Str',
+    default    => 'This command has no help text!',
+    command    => 1,
+    needs_init => 0,
+);
+
+has is_active => (
+    is         => 'rw',
+    isa        => 'Bool',
+    command    => 1,
+    needs_init => 0,
+);
+
+has _ime_plugin => (
+    is       => 'ro',
+    isa      => 'IM::Engine::Plugin',
+    required => 1,
+    weak_ref => 1,
+);
+
+sub default {
+    confess "Commands must implement a default method";
+}
+
+command cmdlist => sub {
+    my $self = shift;
+    my @commands;
+    for my $method ($self->meta->get_all_methods) {
+        push @commands, $method->name
+            if $method->meta->can('does_role')
+            && $method->meta->does_role('IM::Engine::Plugin::Commands::Trait::Method::Command');
+    }
+    return \@commands;
+}, needs_init => 0,
+   formatter => sub {
+       my $list = shift;
+       return join ' ', sort map { '-' . $_ } @$list
+   };
+
+sub say {
+    my $self = shift;
+    $self->_ime_plugin->say(@_);
+}
+
+__PACKAGE__->meta->make_immutable;
+no IM::Engine::Plugin::Commands::OO;
+
+1;
diff --git a/lib/IM/Engine/Plugin/Commands/OO.pm b/lib/IM/Engine/Plugin/Commands/OO.pm
new file mode 100644
index 0000000..132d08a
--- /dev/null
+++ b/lib/IM/Engine/Plugin/Commands/OO.pm
@@ -0,0 +1,69 @@
+package IM::Engine::Plugin::Commands::OO;
+use Moose ();
+use Moose::Exporter;
+use Moose::Util::MetaRole;
+use Scalar::Util qw(blessed reftype);
+
+sub command {
+    my $caller = shift;
+    my $name = shift;
+    my $code;
+    $code = shift if reftype($_[0]) eq 'CODE';
+    my %args = @_;
+
+    my $method_meta = $caller->meta->get_method($name);
+    my $superclass = blessed($method_meta)
+                  || $caller->meta->method_metaclass;
+    my @method_metaclass_roles = ('IM::Engine::Plugin::Commands::Trait::Method::Command');
+    push @method_metaclass_roles, 'IM::Engine::Plugin::Commands::Trait::Method::Formatted'
+        if $args{formatter};
+    my $method_metaclass = Moose::Meta::Class->create_anon_class(
+        superclasses => [$superclass],
+        roles        => \@method_metaclass_roles,
+        cache        => 1,
+    );
+    if ($method_meta) {
+        $method_metaclass->rebless_instance($method_meta);
+    }
+    else {
+        $method_meta = $method_metaclass->name->wrap(
+            $code,
+            package_name => $caller,
+            name         => $name,
+        );
+        $caller->meta->add_method($name, $method_meta);
+    }
+    for my $attr (map { $_->meta->get_attribute_list } @method_metaclass_roles) {
+        next unless exists $args{$attr};
+        my $value = $args{$attr};
+        # XXX: shouldn't this just be a coercion?
+        my $munge_method = "_munge_$attr";
+        $value = $method_meta->$munge_method($value)
+            if $method_meta->can($munge_method);
+        $method_meta->$attr($value);
+    }
+}
+
+Moose::Exporter->setup_import_methods(
+    with_caller => ['command'],
+    also        => ['Moose'],
+);
+
+sub init_meta {
+    shift;
+    my %options = @_;
+    Moose->init_meta(%options);
+    Moose::Util::MetaRole::apply_metaclass_roles(
+        for_class =>
+            $options{for_class},
+        attribute_metaclass_roles =>
+            ['IM::Engine::Plugin::Commands::Trait::Attribute::Command',
+             'IM::Engine::Plugin::Commands::Trait::Attribute::Formatted'],
+        metaclass_roles =>
+            ['IM::Engine::Plugin::Commands::Trait::Class::Command',
+             'IM::Engine::Plugin::Commands::Trait::Class::Formatted'],
+    );
+    return $options{for_class}->meta;
+}
+
+1;
diff --git a/lib/IM/Engine/Plugin/Commands/Trait/Attribute/Command.pm b/lib/IM/Engine/Plugin/Commands/Trait/Attribute/Command.pm
new file mode 100644
index 0000000..bd345dd
--- /dev/null
+++ b/lib/IM/Engine/Plugin/Commands/Trait/Attribute/Command.pm
@@ -0,0 +1,62 @@
+package IM::Engine::Plugin::Commands::Trait::Attribute::Command;
+use Moose::Role;
+
+has command => (
+    is      => 'rw',
+    isa     => 'Bool',
+    default => 0,
+);
+
+has needs_init => (
+    is      => 'rw',
+    isa     => 'Bool',
+    default => 1,
+);
+
+has _use_accessor_metatrait => (
+    is      => 'rw',
+    isa     => 'Bool',
+    default => 0,
+);
+
+before _process_options => sub {
+    my $self = shift;
+    my ($name, $options) = @_;
+    Carp::cluck("needs_init is useless for attributes without command")
+        if exists($options->{needs_init}) && !$options->{command};
+};
+
+around accessor_metaclass => sub {
+    my $orig = shift;
+    my $self = shift;
+    my $metaclass = $self->$orig(@_);
+    return $metaclass unless $self->command && $self->_use_accessor_metatrait;
+    return Moose::Meta::Class->create_anon_class(
+        superclasses => [$metaclass],
+        roles        => ['IM::Engine::Plugin::Commands::Trait::Method::Command'],
+        cache        => 1,
+    )->name;
+};
+
+after install_accessors => sub {
+    my $self = shift;
+    return unless $self->command;
+    my $method_meta = $self->get_read_method_ref;
+    $method_meta->pass_args(0);
+    $method_meta->needs_init($self->needs_init);
+};
+
+around _process_accessors => sub {
+    my $orig = shift;
+    my $self = shift;
+    my ($type) = @_;
+    $self->_use_accessor_metatrait(1) if $type eq 'accessor'
+                                      || $type eq 'reader';
+    my @ret = $self->$orig(@_);
+    $self->_use_accessor_metatrait(0);
+    return @ret;
+};
+
+no Moose::Role;
+
+1;
diff --git a/lib/IM/Engine/Plugin/Commands/Trait/Attribute/Formatted.pm b/lib/IM/Engine/Plugin/Commands/Trait/Attribute/Formatted.pm
new file mode 100644
index 0000000..e7a17e1
--- /dev/null
+++ b/lib/IM/Engine/Plugin/Commands/Trait/Attribute/Formatted.pm
@@ -0,0 +1,58 @@
+package IM::Engine::Plugin::Commands::Trait::Attribute::Formatted;
+use Moose::Role;
+
+# when the attribute is being constructed, the accessor methods haven't been
+# generated yet, so we need to store the formatter here, and then apply it
+# after the accessor methods exist
+has formatter => (
+    is        => 'rw',
+    isa       => 'CodeRef',
+    predicate => 'has_formatter',
+);
+
+before _process_options => sub {
+    my $self = shift;
+    my ($name, $options) = @_;
+    Carp::cluck("only commands will have a formatter applied")
+        if exists($options->{formatter}) && !$options->{command};
+};
+
+after attach_to_class => sub {
+    my $self = shift;
+    my ($meta) = @_;
+    return if $self->has_formatter;
+    return unless $self->command;
+    return unless $self->has_type_constraint;
+    my $tc = $self->type_constraint;
+    for my $tc_name ($meta->formattable_tcs) {
+        if ($tc->is_a_type_of($tc_name)) {
+            $self->formatter($meta->formatter_for($tc_name));
+            return;
+        }
+    }
+};
+
+around accessor_metaclass => sub {
+    my $orig = shift;
+    my $self = shift;
+    my $metaclass = $self->$orig(@_);
+    return $metaclass unless $self->has_formatter;
+    return Moose::Meta::Class->create_anon_class(
+        superclasses => [$metaclass],
+        roles        => ['IM::Engine::Plugin::Commands::Trait::Method::Formatted'],
+        cache        => 1,
+    )->name;
+};
+
+after install_accessors => sub {
+    my $self = shift;
+    if ($self->has_formatter) {
+        my $formatter = $self->formatter;
+        my $method_meta = $self->get_read_method_ref;
+        $method_meta->formatter($formatter);
+    }
+};
+
+no Moose::Role;
+
+1;
diff --git a/lib/IM/Engine/Plugin/Commands/Trait/Class/Command.pm b/lib/IM/Engine/Plugin/Commands/Trait/Class/Command.pm
new file mode 100644
index 0000000..1df9d3e
--- /dev/null
+++ b/lib/IM/Engine/Plugin/Commands/Trait/Class/Command.pm
@@ -0,0 +1,33 @@
+package IM::Engine::Plugin::Commands::Trait::Class::Command;
+use Moose::Role;
+
+after ((map { "add_${_}_method_modifier" } qw/before after around/) => sub {
+    my $self = shift;
+    my $name = shift;
+
+    my $method_meta = $self->get_method($name);
+    my $orig_method_meta = $method_meta->get_original_method;
+    return unless $orig_method_meta->meta->can('does_role')
+               && $orig_method_meta->meta->does_role('IM::Engine::Plugin::Commands::Trait::Method::Command');
+    my $pass_args = $orig_method_meta->pass_args;
+    my $method_metaclass = Moose::Meta::Class->create_anon_class(
+        superclasses => [blessed $method_meta],
+        roles        => ['IM::Engine::Plugin::Commands::Trait::Method::Command'],
+        cache        => 1,
+    );
+    $method_metaclass->rebless_instance($method_meta, pass_args => $pass_args);
+});
+
+sub get_command {
+    my $self = shift;
+    my ($action) = @_;
+    my $method_meta = $self->find_method_by_name($action);
+    return $method_meta
+        if blessed($method_meta)
+        && $method_meta->meta->can('does_role')
+        && $method_meta->meta->does_role('IM::Engine::Plugin::Commands::Trait::Method::Command');
+}
+
+no Moose::Role;
+
+1;
diff --git a/lib/IM/Engine/Plugin/Commands/Trait/Class/Formatted.pm b/lib/IM/Engine/Plugin/Commands/Trait/Class/Formatted.pm
new file mode 100644
index 0000000..71c9249
--- /dev/null
+++ b/lib/IM/Engine/Plugin/Commands/Trait/Class/Formatted.pm
@@ -0,0 +1,26 @@
+package IM::Engine::Plugin::Commands::Trait::Class::Formatted;
+use Moose::Role;
+
+has default_formatters => (
+    traits  => ['Hash'],
+    is      => 'ro',
+    isa     => 'HashRef[CodeRef]',
+    builder => '_build_default_formatters',
+    handles => {
+        formatter_for   => 'get',
+        has_formatter   => 'exists',
+        formattable_tcs => 'keys',
+    },
+);
+
+sub _build_default_formatters {
+    {
+        'ArrayRef' => sub { join ', ', @{ shift() } },
+        'Bool'     => sub { return shift() ? 'true' : 'false' },
+        'Object'   => sub { shift() . "" },
+    }
+}
+
+no Moose::Role;
+
+1;
diff --git a/lib/IM/Engine/Plugin/Commands/Trait/Method/Command.pm b/lib/IM/Engine/Plugin/Commands/Trait/Method/Command.pm
new file mode 100644
index 0000000..670fef1
--- /dev/null
+++ b/lib/IM/Engine/Plugin/Commands/Trait/Method/Command.pm
@@ -0,0 +1,24 @@
+package IM::Engine::Plugin::Commands::Trait::Method::Command;
+use Moose::Role;
+
+has pass_args => (
+    is      => 'rw',
+    isa     => 'Bool',
+    default => 1,
+);
+
+has needs_init => (
+    is      => 'rw',
+    isa     => 'Bool',
+    default => 1,
+);
+
+around execute => sub {
+    my $orig = shift;
+    my $self = shift;
+    return $self->pass_args ? $self->$orig(@_) : $self->$orig($_[0]);
+};
+
+no Moose::Role;
+
+1;
diff --git a/lib/IM/Engine/Plugin/Commands/Trait/Method/Formatted.pm b/lib/IM/Engine/Plugin/Commands/Trait/Method/Formatted.pm
new file mode 100644
index 0000000..82dcd04
--- /dev/null
+++ b/lib/IM/Engine/Plugin/Commands/Trait/Method/Formatted.pm
@@ -0,0 +1,23 @@
+package IM::Engine::Plugin::Commands::Trait::Method::Formatted;
+use Moose::Role;
+use Scalar::Util qw(reftype);
+
+has formatter => (
+    is      => 'rw',
+    isa     => 'CodeRef',
+    default => sub { sub {
+        Carp::cluck "no formatter specified!";
+        return @_;
+    } },
+);
+
+sub _munge_formatter {
+    my $self = shift;
+    my ($format) = @_;
+    return $format if reftype($format) eq 'CODE';
+    return $self->associated_metaclass->formatter_for($format);
+}
+
+no Moose::Role;
+
+1;