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 (file)
--- 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 (file)
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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
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 (file)
--- 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 (file)
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);