X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP%2FMixin%2FHasMethods.pm;h=5f6a4db08d868ce5f3bd5736a3679323283d6647;hb=87a1f36e0f0e38af826028d2dbd8b3d85ccca101;hp=f11f416677719083f7b873c7e74bdacd5f949044;hpb=d5f6cadef8d83deaf7dd95302908cd4f61aeab8a;p=gitmo%2FMoose.git

diff --git a/lib/Class/MOP/Mixin/HasMethods.pm b/lib/Class/MOP/Mixin/HasMethods.pm
index f11f416..5f6a4db 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,84 @@ sub _full_method_map {
     return $self->_method_map;
 }
 
+# overloading
+
+my $overload_operators;
+sub overload_operators {
+    $overload_operators ||= [map { split /\s+/ } values %overload::ops];
+    return @$overload_operators;
+}
+
+sub is_overloaded {
+    my $self = shift;
+    return overload::Overloaded($self->name);
+}
+
+# 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 $self->is_overloaded;
+
+    my %map;
+    for my $op ($self->overload_operators) {
+        my $body = $self->_get_overloaded_operator_body($op);
+        next unless defined $body;
+        $map{$op} = $body;
+    }
+
+    return \%map;
+}
+
+sub get_overload_list {
+    my $self = shift;
+    return keys $self->_overload_map;
+}
+
+sub get_all_overloaded_operators {
+    my $self = shift;
+    my $map = $self->_overload_map;
+    return map { $self->_wrap_overload($_, $map->{$_}) } keys $map;
+}
+
+sub has_overloaded_operator {
+    my $self = shift;
+    my ($op) = @_;
+    return defined $self->_get_overloaded_operator_body($op);
+}
+
+sub get_overloaded_operator {
+    my $self = shift;
+    my ($op) = @_;
+    my $body = $self->_get_overloaded_operator_body($op);
+    return unless defined $body;
+    return $self->_wrap_overload($op, $body);
+}
+
+sub add_overloaded_operator {
+    my $self = shift;
+    my ($op, $body) = @_;
+    $self->name->overload::OVERLOAD($op => $body);
+}
+
+sub _get_overloaded_operator_body {
+    my $self = shift;
+    my ($op) = @_;
+    return overload::Method($self->name, $op);
+}
+
+sub _wrap_overload {
+    my $self = shift;
+    my ($op, $body) = @_;
+    return Class::MOP::Method::Overload->wrap(
+        operator             => $op,
+        package_name         => $self->name,
+        associated_metaclass => $self,
+        body                 => $body,
+    );
+}
+
 1;
 
 # ABSTRACT: Methods for metaclasses which have methods