From d23fc07e2c69e1c3a200092613e40b5e90f73f81 Mon Sep 17 00:00:00 2001 From: Jesse Luehrs Date: Mon, 24 Aug 2009 00:44:17 -0500 Subject: port over the basic structure from Bot::Games --- lib/IM/Engine/Plugin/Commands.pm | 189 +++++++++++++++++++++ lib/IM/Engine/Plugin/Commands/Command.pm | 53 ++++++ lib/IM/Engine/Plugin/Commands/OO.pm | 69 ++++++++ .../Plugin/Commands/Trait/Attribute/Command.pm | 62 +++++++ .../Plugin/Commands/Trait/Attribute/Formatted.pm | 58 +++++++ .../Engine/Plugin/Commands/Trait/Class/Command.pm | 33 ++++ .../Plugin/Commands/Trait/Class/Formatted.pm | 26 +++ .../Engine/Plugin/Commands/Trait/Method/Command.pm | 24 +++ .../Plugin/Commands/Trait/Method/Formatted.pm | 23 +++ 9 files changed, 537 insertions(+) create mode 100644 lib/IM/Engine/Plugin/Commands/Command.pm create mode 100644 lib/IM/Engine/Plugin/Commands/OO.pm create mode 100644 lib/IM/Engine/Plugin/Commands/Trait/Attribute/Command.pm create mode 100644 lib/IM/Engine/Plugin/Commands/Trait/Attribute/Formatted.pm create mode 100644 lib/IM/Engine/Plugin/Commands/Trait/Class/Command.pm create mode 100644 lib/IM/Engine/Plugin/Commands/Trait/Class/Formatted.pm create mode 100644 lib/IM/Engine/Plugin/Commands/Trait/Method/Command.pm create mode 100644 lib/IM/Engine/Plugin/Commands/Trait/Method/Formatted.pm (limited to 'lib') 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; -- cgit v1.2.3-54-g00ecf