Moose-2.1405HEADMoose-2.1405master

1 files changed, 342 insertions, 0 deletions

diff --git a/lib/Class/MOP/Overload.pm b/lib/Class/MOP/Overload.pm
new file mode 100644
index 0000000..8ff81f5
--- /dev/null
+++ b/lib/Class/MOP/Overload.pm
@@ -0,0 +1,342 @@
+package Class::MOP::Overload;
+our $VERSION = '2.1405';
+
+use strict;
+use warnings;
+
+use overload ();
+use Scalar::Util qw( blessed weaken );
+use Try::Tiny;
+
+use parent 'Class::MOP::Object';
+
+my %Operators = (
+    map { $_ => 1 }
+    grep { $_ ne 'fallback' }
+    map  { split /\s+/ } values %overload::ops
+);
+
+sub new {
+    my ( $class, %params ) = @_;
+
+    unless ( defined $params{operator} ) {
+        $class->_throw_exception('OverloadRequiresAnOperator');
+    }
+    unless ( $Operators{ $params{operator} } ) {
+        $class->_throw_exception(
+            'InvalidOverloadOperator',
+            operator => $params{operator},
+        );
+    }
+
+    unless ( defined $params{method_name} || $params{coderef} ) {
+        $class->_throw_exception(
+            'OverloadRequiresAMethodNameOrCoderef',
+            operator => $params{operator},
+        );
+    }
+
+    if ( $params{coderef} ) {
+        unless ( defined $params{coderef_package}
+            && defined $params{coderef_name} ) {
+
+            $class->_throw_exception('OverloadRequiresNamesForCoderef');
+        }
+    }
+
+    if ( $params{method}
+        && !try { $params{method}->isa('Class::MOP::Method') } ) {
+
+        $class->_throw_exception('OverloadRequiresAMetaMethod');
+    }
+
+    if ( $params{associated_metaclass}
+        && !try { $params{associated_metaclass}->isa('Class::MOP::Module') } )
+    {
+
+        $class->_throw_exception('OverloadRequiresAMetaClass');
+    }
+
+    my @optional_attrs
+        = qw( method_name coderef coderef_package coderef_name method associated_metaclass );
+
+    return bless {
+        operator => $params{operator},
+        map { defined $params{$_} ? ( $_ => $params{$_} ) : () }
+            @optional_attrs
+        },
+        $class;
+}
+
+sub operator { $_[0]->{operator} }
+
+sub method_name { $_[0]->{method_name} }
+sub has_method_name { exists $_[0]->{method_name} }
+
+sub method { $_[0]->{method} }
+sub has_method { exists $_[0]->{method} }
+
+sub coderef { $_[0]->{coderef} }
+sub has_coderef { exists $_[0]->{coderef} }
+
+sub coderef_package { $_[0]->{coderef_package} }
+sub has_coderef_package { exists $_[0]->{coderef_package} }
+
+sub coderef_name { $_[0]->{coderef_name} }
+sub has_coderef_name { exists $_[0]->{coderef_name} }
+
+sub associated_metaclass { $_[0]->{associated_metaclass} }
+
+sub is_anonymous {
+    my $self = shift;
+    return $self->has_coderef && $self->coderef_name eq '__ANON__';
+}
+
+sub attach_to_class {
+    my ( $self, $class ) = @_;
+    $self->{associated_metaclass} = $class;
+    weaken $self->{associated_metaclass};
+}
+
+sub clone {
+    my $self = shift;
+
+    my $clone = bless { %{$self}, @_ }, blessed($self);
+    weaken $clone->{associated_metaclass} if $clone->{associated_metaclass};
+
+    $clone->_set_original_overload($self);
+
+    return $clone;
+}
+
+sub original_overload { $_[0]->{original_overload} }
+sub _set_original_overload { $_[0]->{original_overload} = $_[1] }
+
+sub _is_equal_to {
+    my $self  = shift;
+    my $other = shift;
+
+    if ( $self->has_coderef ) {
+        return unless $other->has_coderef;
+        return $self->coderef == $other->coderef;
+    }
+    else {
+        return $self->method_name eq $other->method_name;
+    }
+}
+
+1;
+
+# ABSTRACT: Overload Meta Object
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Class::MOP::Overload - Overload Meta Object
+
+=head1 VERSION
+
+version 2.1405
+
+=head1 SYNOPSIS
+
+    my $meta     = Class->meta;
+    my $overload = $meta->get_overloaded_operator('+');
+
+    if ( $overload->has_method_name ) {
+        print 'Method for + is ', $overload->method_name, "\n";
+    }
+    else {
+        print 'Overloading for + is implemented by ',
+            $overload->coderef_name, " sub\n";
+    }
+
+=head1 DESCRIPTION
+
+This class provides meta information for overloading in classes and roles.
+
+=head1 INHERITANCE
+
+C<Class::MOP::Overload> is a subclass of L<Class::MOP::Object>.
+
+=head1 METHODS
+
+This class provides the following methods:
+
+=head2 Class::MOP::Overload->new(%options)
+
+This method creates a new C<Class::MOP::Overload> object. It accepts a number
+of options:
+
+=over 4
+
+=item * operator
+
+This is a string that matches an operator known by the L<overload> module,
+such as C<""> or C<+>. This is required.
+
+=item * method_name
+
+The name of the method which implements the overloading. Note that this does
+not need to actually correspond to a real method, since it's okay to declare a
+not-yet-implemented overloading.
+
+Either this or the C<coderef> option must be passed.
+
+=item * method
+
+A L<Class::MOP::Method> object for the method which implements the
+overloading.
+
+This is optional.
+
+=item * coderef
+
+A coderef which implements the overloading.
+
+Either this or the C<method_name> option must be passed.
+
+=item * coderef_package
+
+The package where the coderef was defined.
+
+This is required if C<coderef> is passed.
+
+=item * coderef_name
+
+The name of the coderef. This can be "__ANON__".
+
+This is required if C<coderef> is passed.
+
+=item * associated_metaclass
+
+A L<Class::MOP::Module> object for the associated class or role.
+
+This is optional.
+
+=back
+
+=head2 $overload->operator
+
+Returns the operator for this overload object.
+
+=head2 $overload->method_name
+
+Returns the method name that implements overloading, if it has one.
+
+=head2 $overload->has_method_name
+
+Returns true if the object has a method name.
+
+=head2 $overload->method
+
+Returns the L<Class::MOP::Method> that implements overloading, if it has one.
+
+=head2 $overload->has_method
+
+Returns true if the object has a method.
+
+=head2 $overload->coderef
+
+Returns the coderef that implements overloading, if it has one.
+
+=head2 $overload->has_coderef
+
+Returns true if the object has a coderef.
+
+=head2 $overload->coderef_package
+
+Returns the package for the coderef that implements overloading, if it has
+one.
+
+=head2 $overload->has_coderef
+
+Returns true if the object has a coderef package.
+
+=head2 $overload->coderef_name
+
+Returns the sub name for the coderef that implements overloading, if it has
+one.
+
+=head2 $overload->has_coderef_name
+
+Returns true if the object has a coderef name.
+
+=head2 $overload->is_anonymous
+
+Returns true if the overloading is implemented by an anonymous coderef.
+
+=head2 $overload->associated_metaclass
+
+Returns the L<Class::MOP::Module> (class or role) that is associated with the
+overload object.
+
+=head2 $overload->clone
+
+Clones the overloading object, setting C<original_overload> in the process.
+
+=head2 $overload->original_overload
+
+For cloned objects, this returns the L<Class::MOP::Overload> object from which
+they were cloned. This can be used to determine the source of an overloading
+in a class that came from a role, for example.
+
+=head1 AUTHORS
+
+=over 4
+
+=item *
+
+Stevan Little <stevan.little@iinteractive.com>
+
+=item *
+
+Dave Rolsky <autarch@urth.org>
+
+=item *
+
+Jesse Luehrs <doy@tozt.net>
+
+=item *
+
+Shawn M Moore <code@sartak.org>
+
+=item *
+
+יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
+
+=item *
+
+Karen Etheridge <ether@cpan.org>
+
+=item *
+
+Florian Ragwitz <rafl@debian.org>
+
+=item *
+
+Hans Dieter Pearcey <hdp@weftsoar.net>
+
+=item *
+
+Chris Prather <chris@prather.org>
+
+=item *
+
+Matt S Trout <mst@shadowcat.co.uk>
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2006 by Infinity Interactive, Inc..
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut