Switch to Mouse::Exporter

[gitmo/Mouse.git] / lib / Mouse / Meta / Method / Accessor.pm

diff --git a/lib/Mouse/Meta/Method/Accessor.pm b/lib/Mouse/Meta/Method/Accessor.pm
index 56478d7..6e1055c 100755 (executable)
--- a/lib/Mouse/Meta/Method/Accessor.pm
+++ b/lib/Mouse/Meta/Method/Accessor.pm
@@ -1,9 +1,9 @@
 package Mouse::Meta::Method::Accessor;
-use strict;
-use warnings;
+use Mouse::Util; # enables strict and warnings
+use Scalar::Util qw(blessed);
 
-sub _install_accessor{
-    my (undef, $attribute, $method_name, $class, $type) = @_;
+sub _generate_accessor{
+    my (undef, $attribute, $class, $type) = @_;
 
     my $name          = $attribute->name;
     my $default       = $attribute->default;
@@ -14,16 +14,17 @@ sub _install_accessor{
     my $should_deref  = $attribute->should_auto_deref;
     my $should_coerce = $attribute->should_coerce;
 
-    my $compiled_type_constraint    = $constraint ? $constraint->{_compiled_type_constraint} : undef;
+    my $compiled_type_constraint = $constraint ? $constraint->_compiled_type_constraint : undef;
 
     my $self  = '$_[0]';
-    my $key   = $attribute->_inlined_name;
+    my $key   = sprintf q{"%s"}, quotemeta $name;
 
     $type ||= 'accessor';
 
     my $accessor = 
         '#line ' . __LINE__ . ' "' . __FILE__ . "\"\n" .
         "sub {\n";
+
     if ($type eq 'accessor' || $type eq 'writer') {
         if($type eq 'accessor'){
             $accessor .= 
@@ -33,35 +34,29 @@ sub _install_accessor{
         else{ # writer
             $accessor .= 
                 '#line ' . __LINE__ . ' "' . __FILE__ . "\"\n" .
-                'if(@_ < 2){ Carp::confess("Not enough arguments for writer '.$method_name.'") }'.
+                'if(@_ < 2){ Carp::confess("Not enough arguments for the writer of '.$name.'") }'.
                 '{' . "\n";
         }
                 
         my $value = '$_[1]';
 
-        if ($constraint) {
+        if (defined $constraint) {
+            if(!$compiled_type_constraint){
+                Carp::confess("[BUG] Missing compiled type constraint for $constraint");
+            }
             if ($should_coerce) {
                 $accessor .=
                     "\n".
                     '#line ' . __LINE__ . ' "' . __FILE__ . "\"\n" .
-                    'my $val = Mouse::Util::TypeConstraints->typecast_constraints("'.$attribute->associated_class->name.'", $attribute->{type_constraint}, '.$value.');';
+                    'my $val = $constraint->coerce('.$value.');';
                 $value = '$val';
             }
-            if ($compiled_type_constraint) {
-                $accessor .= 
-                    "\n".
-                    '#line ' . __LINE__ . ' "' . __FILE__ . "\"\n" .
-                    'unless ($compiled_type_constraint->('.$value.')) {
-                        $attribute->verify_type_constraint_error($name, '.$value.', $attribute->{type_constraint});
-                    }' . "\n";
-            } else {
-                $accessor .= 
-                    "\n".
-                    '#line ' . __LINE__ . ' "' . __FILE__ . "\"\n" .
-                    'unless ($constraint->check('.$value.')) {
-                        $attribute->verify_type_constraint_error($name, '.$value.', $attribute->{type_constraint});
-                    }' . "\n";
-            }
+            $accessor .= 
+                "\n".
+                '#line ' . __LINE__ . ' "' . __FILE__ . "\"\n" .
+                'unless ($compiled_type_constraint->('.$value.')) {
+                    $attribute->verify_type_constraint_error($name, '.$value.', $attribute->{type_constraint});
+                }' . "\n";
         }
 
         # if there's nothing left to do for the attribute we can return during
@@ -90,11 +85,16 @@ sub _install_accessor{
     if ($attribute->is_lazy) {
         $accessor .= $self.'->{'.$key.'} = ';
 
-        $accessor .= $attribute->has_builder
-                ? $self.'->$builder'
-                    : ref($default) eq 'CODE'
-                    ? '$default->('.$self.')'
-                    : '$default';
+        if($should_coerce && defined($constraint)){
+            $accessor .= '$attribute->_coerce_and_verify(';
+        }
+        $accessor .=   $attribute->has_builder ? $self.'->$builder'
+                     : ref($default) eq 'CODE' ? '$default->('.$self.')'
+                     :                           '$default';
+
+        if($should_coerce && defined $constraint){
+            $accessor .= ')';
+        }
         $accessor .= ' if !exists '.$self.'->{'.$key.'};' . "\n";
     }
 
@@ -117,79 +117,67 @@ sub _install_accessor{
     $accessor .= 'return '.$self.'->{'.$key."};\n}";
 
     #print $accessor, "\n";
-    my $code = eval $accessor;
-    $attribute->throw_error($@) if $@;
-
-    $class->add_method($method_name => $code);
-    return;
+    my $code;
+    my $e = do{
+        local $@;
+        $code = eval $accessor;
+        $@;
+    };
+    die $e if $e;
+
+    return $code;
 }
 
-sub _install_reader{
+sub _generate_reader{
     my $class = shift;
-    $class->_install_accessor(@_, 'reader');
-    return;
+    return $class->_generate_accessor(@_, 'reader');
 }
 
-sub _install_writer{
+sub _generate_writer{
     my $class = shift;
-    $class->_install_accessor(@_, 'writer');
-    return;
+    return $class->_generate_accessor(@_, 'writer');
 }
 
 
-sub _install_predicate {
-    my (undef, $attribute, $method_name, $class) = @_;
+sub _generate_predicate {
+    my (undef, $attribute, $class) = @_;
 
-    my $key = $attribute->_inlined_name;
-
-    my $predicate = 'sub { exists($_[0]->{'.$key.'}) }';
-
-    my $code = eval $predicate;
-    $attribute->throw_error($@) if $@;
-    $class->add_method($method_name => $code);
-    return;
+    my $slot = $attribute->name;
+    return sub{
+        return exists $_[0]->{$slot};
+    };
 }
 
-sub _install_clearer {
-    my (undef, $attribute, $method_name, $class) = @_;
+sub _generate_clearer {
+    my (undef, $attribute, $class) = @_;
 
-    my $key = $attribute->_inlined_name;
+    my $slot = $attribute->name;
 
-    my $clearer = 'sub { delete($_[0]->{'.$key.'}) }';
-
-    my $code = eval $clearer;
-    $attribute->throw_error($@) if $@;
-    $class->add_method($method_name => $code);
-    return;
+   return sub{
+        delete $_[0]->{$slot};
+    };
 }
 
-sub _install_handles {
-    my (undef, $attribute, $handles, $class) = @_;
-
-    my $reader  = $attribute->name;
-    my %handles = $attribute->_canonicalize_handles($handles);
-
-    my @methods;
-
-    foreach my $local_method (keys %handles) {
-        my $remote_method = $handles{$local_method};
-
-        my $method = 'sub {
-            my $self = shift;
-            $self->'.$reader.'->'.$remote_method.'(@_)
-        }';
-
-        my $code = eval $method;
-        $attribute->throw_error($@) if $@;
-
-        push @methods, ($local_method => $code);
-    }
-
-    # install after all the method compiled successfully
-    while(my($name, $code) = splice @methods, 0, 2){
-        $class->add_method($name, $code);
-    }
-    return;
+sub _generate_delegation{
+    my (undef, $attribute, $class, $reader, $handle_name, $method_to_call) = @_;
+
+    return sub {
+        my $instance = shift;
+        my $proxy    = $instance->$reader();
+
+        my $error = !defined($proxy)                ? ' is not defined'
+                  : ref($proxy) && !blessed($proxy) ? qq{ is not an object (got '$proxy')}
+                                                    : undef;
+        if ($error) {
+            $instance->meta->throw_error(
+                "Cannot delegate $handle_name to $method_to_call because "
+                    . "the value of "
+                    . $attribute->name
+                    . $error
+             );
+        }
+        $proxy->$method_to_call(@_);
+    };
 }