diff options
author | Jesse Luehrs <doy@tozt.net> | 2009-08-24 00:44:17 -0500 |
---|---|---|
committer | Jesse Luehrs <doy@tozt.net> | 2009-08-24 02:29:40 -0500 |
commit | d23fc07e2c69e1c3a200092613e40b5e90f73f81 (patch) | |
tree | b6d4a38cf17b1b40e286fc94c189eda2d5e22c39 /lib/IM/Engine/Plugin/Commands | |
parent | cad0cd7a59ac086fe2ba6264440a517cd34bf223 (diff) | |
download | im-engine-plugin-commands-d23fc07e2c69e1c3a200092613e40b5e90f73f81.tar.gz im-engine-plugin-commands-d23fc07e2c69e1c3a200092613e40b5e90f73f81.zip |
port over the basic structure from Bot::Games
Diffstat (limited to 'lib/IM/Engine/Plugin/Commands')
-rw-r--r-- | lib/IM/Engine/Plugin/Commands/Command.pm | 53 | ||||
-rw-r--r-- | lib/IM/Engine/Plugin/Commands/OO.pm | 69 | ||||
-rw-r--r-- | lib/IM/Engine/Plugin/Commands/Trait/Attribute/Command.pm | 62 | ||||
-rw-r--r-- | lib/IM/Engine/Plugin/Commands/Trait/Attribute/Formatted.pm | 58 | ||||
-rw-r--r-- | lib/IM/Engine/Plugin/Commands/Trait/Class/Command.pm | 33 | ||||
-rw-r--r-- | lib/IM/Engine/Plugin/Commands/Trait/Class/Formatted.pm | 26 | ||||
-rw-r--r-- | lib/IM/Engine/Plugin/Commands/Trait/Method/Command.pm | 24 | ||||
-rw-r--r-- | lib/IM/Engine/Plugin/Commands/Trait/Method/Formatted.pm | 23 |
8 files changed, 348 insertions, 0 deletions
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; |