From: Jesse Luehrs Date: Mon, 13 Feb 2012 01:17:57 +0000 (-0600) Subject: start sketching out an overload api for the mop X-Git-Tag: 2.0500~26 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=2683d371fec5a97c460fee1a8d03339e30c8667d;p=gitmo%2FMoose.git start sketching out an overload api for the mop --- diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index fce3380..c1b22c2 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -697,6 +697,7 @@ $_->meta->make_immutable( Class::MOP::Method::Wrapped Class::MOP::Method::Meta + Class::MOP::Method::Overload /; $_->meta->make_immutable( diff --git a/lib/Class/MOP/Method/Overload.pm b/lib/Class/MOP/Method/Overload.pm new file mode 100644 index 0000000..68ccc3a --- /dev/null +++ b/lib/Class/MOP/Method/Overload.pm @@ -0,0 +1,46 @@ + +package Class::MOP::Method::Overload; + +use strict; +use warnings; + +use Carp 'confess'; + +use base 'Class::MOP::Method'; + +sub wrap { + my $class = shift; + my (@args) = @_; + unshift @args, 'body' if @args % 2 == 1; + my %params = @args; + + confess "op is required" + unless exists $params{op}; + + return $class->SUPER::wrap( + name => "($params{op}", + %params, + ); +} + +sub _new { + my $class = shift; + return Class::MOP::Class->initialize($class)->new_object(@_) + if $class ne __PACKAGE__; + + my $params = @_ == 1 ? $_[0] : {@_}; + + return bless { + # inherited from Class::MOP::Method + 'body' => $params->{body}, + 'associated_metaclass' => $params->{associated_metaclass}, + 'package_name' => $params->{package_name}, + 'name' => $params->{name}, + 'original_method' => $params->{original_method}, + + # defined in this class + 'op' => $params->{op}, + } => $class; +} + +1; diff --git a/lib/Class/MOP/Mixin/HasMethods.pm b/lib/Class/MOP/Mixin/HasMethods.pm index f11f416..e0ecb3a 100644 --- a/lib/Class/MOP/Mixin/HasMethods.pm +++ b/lib/Class/MOP/Mixin/HasMethods.pm @@ -4,11 +4,14 @@ use strict; use warnings; use Class::MOP::Method::Meta; +use Class::MOP::Method::Overload; use Scalar::Util 'blessed'; use Carp 'confess'; use Sub::Name 'subname'; +use overload (); + use base 'Class::MOP::Mixin'; sub _meta_method_class { 'Class::MOP::Method::Meta' } @@ -200,6 +203,72 @@ sub _full_method_map { return $self->_method_map; } +# overloading + +my $overload_ops; +sub overload_ops { + $overload_ops ||= [map { split /\s+/ } values %overload::ops]; +} + +# XXX this could probably stand to be cached, but i figure it should be +# uncommon enough to not particularly matter +sub _overload_map { + my $self = shift; + + return {} unless overload::Overloaded($self->name); + + my %map; + for my $op (@{ $self->overload_ops }) { + my $body = overload::Method($self->name, $op); + next unless defined $body; + $map{$op} = $body; + } + + return \%map; +} + +sub get_overload_list { + my $self = shift; + my $map = $self->_overload_map; + return map { $self->_wrap_overload($_, $map->{$_}) } keys $map; +} + +sub get_overloaded_ops { + my $self = shift; + return keys $self->_overload_map; +} + +sub has_overloaded_op { + my $self = shift; + my ($op) = @_; + return defined overload::Method($op); +} + +sub get_overloaded_op { + my $self = shift; + my ($op) = @_; + my $body = overload::Method($op); + return unless defined $body; + return $self->_wrap_overload($op, $body); +} + +sub add_overload { + my $self = shift; + my ($op, $body) = @_; + overload->import($op => $body); +} + +sub _wrap_overload { + my $self = shift; + my ($op, $body) = @_; + return Class::MOP::Method::Overload->wrap( + op => $op, + package_name => $self->name, + associated_metaclass => $self, + body => $body, + ); +} + 1; # ABSTRACT: Methods for metaclasses which have methods diff --git a/mop.c b/mop.c index 5b14f8f..6f58b48 100644 --- a/mop.c +++ b/mop.c @@ -220,7 +220,8 @@ static struct { DECLARE_KEY(wrapped_method_metaclass), DECLARE_KEY(writer), DECLARE_KEY_WITH_VALUE(package_cache_flag, "_package_cache_flag"), - DECLARE_KEY_WITH_VALUE(_version, "-version") + DECLARE_KEY_WITH_VALUE(_version, "-version"), + DECLARE_KEY(op) }; SV * diff --git a/mop.h b/mop.h index 4b02796..92ba852 100644 --- a/mop.h +++ b/mop.h @@ -64,6 +64,7 @@ typedef enum { KEY_writer, KEY_package_cache_flag, KEY__version, + KEY_op, key_last, } mop_prehashed_key_t; diff --git a/t/cmop/load.t b/t/cmop/load.t index 6c135b3..7e5a94d 100644 --- a/t/cmop/load.t +++ b/t/cmop/load.t @@ -23,6 +23,7 @@ BEGIN { use_ok('Class::MOP::Method::Accessor'); use_ok('Class::MOP::Method::Constructor'); use_ok('Class::MOP::Method::Meta'); + use_ok('Class::MOP::Method::Overload'); use_ok('Class::MOP::Instance'); use_ok('Class::MOP::Object'); } @@ -36,6 +37,7 @@ my %METAS = ( 'Class::MOP::Method::Accessor' => Class::MOP::Method::Accessor->meta, 'Class::MOP::Method::Constructor' => Class::MOP::Method::Constructor->meta, 'Class::MOP::Method::Meta' => Class::MOP::Method::Meta->meta, + 'Class::MOP::Method::Overload' => Class::MOP::Method::Overload->meta, 'Class::MOP::Mixin' => Class::MOP::Mixin->meta, 'Class::MOP::Mixin::AttributeCore' => Class::MOP::Mixin::AttributeCore->meta, 'Class::MOP::Mixin::HasAttributes' => Class::MOP::Mixin::HasAttributes->meta, @@ -91,6 +93,7 @@ is_deeply( Class::MOP::Method::Generated->meta, Class::MOP::Method::Inlined->meta, Class::MOP::Method::Meta->meta, + Class::MOP::Method::Overload->meta, Class::MOP::Method::Wrapped->meta, Class::MOP::Mixin->meta, Class::MOP::Mixin::AttributeCore->meta, @@ -124,6 +127,7 @@ is_deeply( Class::MOP::Method::Inlined Class::MOP::Method::Wrapped Class::MOP::Method::Meta + Class::MOP::Method::Overload Class::MOP::Module Class::MOP::Object Class::MOP::Package diff --git a/t/metaclasses/overloading.t b/t/metaclasses/overloading.t new file mode 100644 index 0000000..c6c3659 --- /dev/null +++ b/t/metaclasses/overloading.t @@ -0,0 +1,38 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; + +{ + package Foo; + use Moose; +} + +{ + is_deeply([Foo->meta->get_overload_list], []); + is_deeply([Foo->meta->get_overloaded_ops], []); +} + +my $plus; +my $plus_impl; +BEGIN { $plus_impl = sub { $plus = 1; $_[0] + $_[1] } } +{ + package Foo::Overloaded; + use Moose; + use overload '+' => $plus_impl; +} + +{ + is_deeply([Foo::Overloaded->meta->get_overloaded_ops], ['+']); + my @overloads = Foo::Overloaded->meta->get_overload_list; + is(scalar(@overloads), 1); + my $plus_meth = $overloads[0]; + isa_ok($plus_meth, 'Class::MOP::Method::Overload'); + is($plus_meth->op, '+'); + is($plus_meth->name, '(+'); + is($plus_meth->body, $plus_impl); + is($plus_meth->package_name, 'Foo::Overloaded'); + is($plus_meth->associated_metaclass, Foo::Overloaded->meta); +} + +done_testing; diff --git a/xs/Moose.xs b/xs/Moose.xs index ce0ddbf..06b983e 100644 --- a/xs/Moose.xs +++ b/xs/Moose.xs @@ -119,6 +119,7 @@ XS_EXTERNAL(boot_Class__MOP__Mixin__AttributeCore); XS_EXTERNAL(boot_Class__MOP__Method); XS_EXTERNAL(boot_Class__MOP__Method__Inlined); XS_EXTERNAL(boot_Class__MOP__Method__Generated); +XS_EXTERNAL(boot_Class__MOP__Method__Overload); XS_EXTERNAL(boot_Class__MOP__Class); XS_EXTERNAL(boot_Class__MOP__Attribute); XS_EXTERNAL(boot_Class__MOP__Instance); @@ -138,6 +139,7 @@ BOOT: MOP_CALL_BOOT (boot_Class__MOP__Method); MOP_CALL_BOOT (boot_Class__MOP__Method__Inlined); MOP_CALL_BOOT (boot_Class__MOP__Method__Generated); + MOP_CALL_BOOT (boot_Class__MOP__Method__Overload); MOP_CALL_BOOT (boot_Class__MOP__Class); MOP_CALL_BOOT (boot_Class__MOP__Attribute); MOP_CALL_BOOT (boot_Class__MOP__Instance); diff --git a/xs/Overload.xs b/xs/Overload.xs new file mode 100644 index 0000000..eac5ae5 --- /dev/null +++ b/xs/Overload.xs @@ -0,0 +1,8 @@ +#include "mop.h" + +MODULE = Class::MOP::Method::Overload PACKAGE = Class::MOP::Method::Overload + +PROTOTYPES: DISABLE + +BOOT: + INSTALL_SIMPLE_READER(Method::Overload, op);