X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMethod%2FGenerate%2FAccessor.pm;h=4a8ecd39638550e298af2963250ee2cfa7de2cfa;hb=faa9ce11cefee1e6f7800ec1dbe561717c162161;hp=7015ada121c5a9ce89dc707666236f447324e934;hpb=32381de9e49e74a628cf68a24bbc96232c70a65b;p=gitmo%2FRole-Tiny.git

diff --git a/lib/Method/Generate/Accessor.pm b/lib/Method/Generate/Accessor.pm
index 7015ada..4a8ecd3 100644
--- a/lib/Method/Generate/Accessor.pm
+++ b/lib/Method/Generate/Accessor.pm
@@ -7,9 +7,11 @@ use Sub::Quote;
 use B 'perlstring';
 BEGIN {
   our $CAN_HAZ_XS =
+    !$ENV{MOO_XS_DISABLE}
+      &&
     _maybe_load_module('Class::XSAccessor')
       &&
-    (Class::XSAccessor->VERSION > 1.06)
+    (eval { Class::XSAccessor->VERSION('1.07') })
   ;
 }
 
@@ -38,7 +40,8 @@ sub generate_method {
       $self->{captures} = {};
       $methods{$reader} =
         quote_sub "${into}::${reader}"
-          => $self->_generate_get($name, $spec)
+          => '    die "'.$reader.' is a read-only accessor" if @_ > 1;'."\n"
+             .$self->_generate_get($name, $spec)
           => delete $self->{captures}
         ;
     }
@@ -130,7 +133,7 @@ sub is_simple_attribute {
   # clearer doesn't have to be listed because it doesn't
   # affect whether defined/exists makes a difference
   !grep $spec->{$_},
-    qw(lazy default builder isa trigger predicate weak_ref);
+    qw(lazy default builder coerce isa trigger predicate weak_ref);
 }
 
 sub is_simple_get {
@@ -140,7 +143,12 @@ sub is_simple_get {
 
 sub is_simple_set {
   my ($self, $name, $spec) = @_;
-  !grep $spec->{$_}, qw(isa trigger weak_ref);
+  !grep $spec->{$_}, qw(coerce isa trigger weak_ref);
+}
+
+sub has_eager_default {
+  my ($self, $name, $spec) = @_;
+  (!$spec->{lazy} and ($spec->{default} or $spec->{builder}));
 }
 
 sub _generate_get {
@@ -198,9 +206,14 @@ sub _generate_set {
   if ($self->is_simple_set($name, $spec)) {
     $self->_generate_simple_set('$_[0]', $name, $spec, '$_[1]');
   } else {
-    my ($trigger, $isa_check) = @{$spec}{qw(trigger isa)};
+    my ($coerce, $trigger, $isa_check) = @{$spec}{qw(coerce trigger isa)};
     my $simple = $self->_generate_simple_set('$self', $name, $spec, '$value');
     my $code = "do { my (\$self, \$value) = \@_;\n";
+    if ($coerce) {
+      $code .=
+        "        \$value = "
+        .$self->_generate_coerce($name, '$self', '$value', $coerce).";\n";
+    }
     if ($isa_check) {
       $code .= 
         "        ".$self->_generate_isa_check($name, '$value', $isa_check).";\n";
@@ -217,7 +230,19 @@ sub _generate_set {
     $code;
   }
 }
-  
+
+sub generate_coerce {
+  my $self = shift;
+  $self->{captures} = {};
+  my $code = $self->_generate_coerce(@_);
+  ($code, delete $self->{captures});
+}
+
+sub _generate_coerce {
+  my ($self, $name, $obj, $value, $coerce) = @_;
+  $self->_generate_call_code($name, 'coerce', "${value}", $coerce);
+}
+ 
 sub generate_trigger {
   my $self = shift;
   $self->{captures} = {};
@@ -272,15 +297,23 @@ sub generate_populate_set {
 
 sub _generate_populate_set {
   my ($self, $me, $name, $spec, $source, $test) = @_;
-  if (!$spec->{lazy} and
-        ($spec->{default} or $spec->{builder})) {
+  if ($self->has_eager_default($name, $spec)) {
     my $get_indent = ' ' x ($spec->{isa} ? 6 : 4);
+    my $get_default = $self->_generate_get_default(
+                        '$new', $_, $spec
+                      );
     my $get_value = 
-      "(\n${get_indent}  ${test}\n${get_indent}   ? ${source}\n${get_indent}   : "
-        .$self->_generate_get_default(
-          '$new', $_, $spec
-        )
-        ."\n${get_indent})";
+      defined($spec->{init_arg})
+        ? "(\n${get_indent}  ${test}\n${get_indent}   ? ${source}\n${get_indent}   : "
+            .$get_default
+            ."\n${get_indent})"
+        : $get_default;
+    if ( $spec->{coerce} ) {
+        $get_value = $self->_generate_coerce(
+            $name, $me, $get_value,
+            $spec->{coerce}
+          )
+    }
     ($spec->{isa}
       ? "    {\n      my \$value = ".$get_value.";\n      "
         .$self->_generate_isa_check(
@@ -300,6 +333,14 @@ sub _generate_populate_set {
     );
   } else {
     "    if (${test}) {\n"
+      .($spec->{coerce}
+        ? "      $source = "
+          .$self->_generate_coerce(
+            $name, $me, $source,
+            $spec->{coerce}
+          ).";\n"
+        : ""
+      )
       .($spec->{isa}
         ? "      "
           .$self->_generate_isa_check(
@@ -329,9 +370,33 @@ sub _generate_simple_set {
   my ($self, $me, $name, $spec, $value) = @_;
   my $name_str = perlstring $name;
   my $simple = "${me}->{${name_str}} = ${value}";
+
   if ($spec->{weak_ref}) {
     require Scalar::Util;
-    "Scalar::Util::weaken(${simple})";
+
+    # Perl < 5.8.3 can't weaken refs to readonly vars
+    # (e.g. string constants). This *can* be solved by:
+    #
+    #Internals::SetReadWrite($foo);
+    #Scalar::Util::weaken ($foo);
+    #Internals::SetReadOnly($foo);
+    #
+    # but requires XS and is just too damn crazy
+    # so simply throw a better exception
+    Moo::_Utils::lt_5_8_3() ? <<"EOC" : "Scalar::Util::weaken(${simple})";
+
+      eval { Scalar::Util::weaken($simple); 1 } or do {
+        if( \$@ =~ /Modification of a read-only value attempted/) {
+          require Carp;
+          Carp::croak( sprintf (
+            'Reference to readonly value in "%s" can not be weakened on Perl < 5.8.3',
+            $name_str,
+          ) );
+        } else {
+          die \$@;
+        }
+      };
+EOC
   } else {
     $simple;
   }