From: Dave Rolsky <autarch@urth.org>
Date: Mon, 26 Jul 2010 17:49:03 +0000 (-0500)
Subject: Squashed commit of the following:
X-Git-Tag: 1.05~17
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=8343d5018a33fdbd5b727e99d009f06ec54f10b9;p=gitmo%2FClass-MOP.git

Squashed commit of the following:

commit 255fa25a0a956ccac7b8a3c0434321bef3b67942
Author: Jesse Luehrs <doy@tozt.net>
Date:   Mon Jul 5 19:26:30 2010 -0500

    just close over the default value, stop fiddling with reparsing

commit e78f18dd84e155eccae4986de1de2d8adf0e4373
Author: Jesse Luehrs <doy@tozt.net>
Date:   Mon Jul 5 17:32:45 2010 -0500

    support default => undef better

commit 7be1d004a96a44cc93b0a85bdfb26e6be647e77d
Author: Jesse Luehrs <doy@tozt.net>
Date:   Mon Jul 5 17:24:49 2010 -0500

    refactor out default generation into something moose can use
---

diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm
index 1faf85c..4696e82 100644
--- a/lib/Class/MOP/Attribute.pm
+++ b/lib/Class/MOP/Attribute.pm
@@ -73,7 +73,9 @@ sub _new {
         'clearer'            => $options->{clearer},
         'builder'            => $options->{builder},
         'init_arg'           => $options->{init_arg},
-        'default'            => $options->{default},
+        exists $options->{default}
+            ? ('default'     => $options->{default})
+            : (),
         'initializer'        => $options->{initializer},
         'definition_context' => $options->{definition_context},
         # keep a weakened link to the
@@ -117,7 +119,7 @@ sub initialize_instance_slot {
             $params->{$init_arg},
         );
     } 
-    elsif (defined $self->{'default'}) {
+    elsif (exists $self->{'default'}) {
         $self->_set_initial_slot_value(
             $meta_instance, 
             $instance,
diff --git a/lib/Class/MOP/Method/Constructor.pm b/lib/Class/MOP/Method/Constructor.pm
index 3fafd24..df68a61 100644
--- a/lib/Class/MOP/Method/Constructor.pm
+++ b/lib/Class/MOP/Method/Constructor.pm
@@ -5,7 +5,7 @@ use strict;
 use warnings;
 
 use Carp         'confess';
-use Scalar::Util 'blessed', 'weaken', 'looks_like_number';
+use Scalar::Util 'blessed', 'weaken';
 
 our $VERSION   = '1.04';
 $VERSION = eval $VERSION;
@@ -100,7 +100,11 @@ sub _generate_constructor_method {
 sub _generate_constructor_method_inline {
     my $self = shift;
 
-    my $close_over = {};
+    my $defaults = [map { $_->default } @{ $self->_attributes }];
+
+    my $close_over = {
+        '$defaults' => \$defaults,
+    };
 
     my $source = 'sub {';
     $source .= "\n" . 'my $class = shift;';
@@ -111,8 +115,9 @@ sub _generate_constructor_method_inline {
     $source .= "\n" . 'my $params = @_ == 1 ? $_[0] : {@_};';
 
     $source .= "\n" . 'my $instance = ' . $self->_meta_instance->inline_create_instance('$class');
+    my $idx = 0;
     $source .= ";\n" . (join ";\n" => map {
-        $self->_generate_slot_initializer($_, $close_over)
+        $self->_generate_slot_initializer($_, $idx++)
     } @{ $self->_attributes });
     $source .= ";\n" . 'return $instance';
     $source .= ";\n" . '}';
@@ -130,28 +135,11 @@ sub _generate_constructor_method_inline {
 sub _generate_slot_initializer {
     my $self  = shift;
     my $attr  = shift;
-    my $close = shift;
+    my $idx   = shift;
 
     my $default;
     if ($attr->has_default) {
-        # NOTE:
-        # default values can either be CODE refs
-        # in which case we need to call them. Or
-        # they can be scalars (strings/numbers)
-        # in which case we can just deal with them
-        # in the code we eval.
-        if ($attr->is_default_a_coderef) {
-            my $idx = @{$close->{'@defaults'}||=[]};
-            push(@{$close->{'@defaults'}}, $attr->default);
-            $default = '$defaults[' . $idx . ']->($instance)';
-        }
-        else {
-            $default = $attr->default;
-            # make sure to quote strings ...
-            unless (looks_like_number($default)) {
-                $default = "'$default'";
-            }
-        }
+        $default = $self->_generate_default_value($attr, $idx);
     } elsif( $attr->has_builder ) {
         $default = '$instance->'.$attr->builder;
     }
@@ -180,6 +168,22 @@ sub _generate_slot_initializer {
     } else { return '' }
 }
 
+sub _generate_default_value {
+    my ($self, $attr, $index) = @_;
+    # NOTE:
+    # default values can either be CODE refs
+    # in which case we need to call them. Or
+    # they can be scalars (strings/numbers)
+    # in which case we can just deal with them
+    # in the code we eval.
+    if ($attr->is_default_a_coderef) {
+        return '$defaults->[' . $index . ']->($instance)';
+    }
+    else {
+        return '$defaults->[' . $index . ']';
+    }
+}
+
 1;
 
 __END__
diff --git a/lib/Class/MOP/Mixin/AttributeCore.pm b/lib/Class/MOP/Mixin/AttributeCore.pm
index bf6f669..997cb7b 100644
--- a/lib/Class/MOP/Mixin/AttributeCore.pm
+++ b/lib/Class/MOP/Mixin/AttributeCore.pm
@@ -18,7 +18,7 @@ sub has_predicate       { defined $_[0]->{'predicate'} }
 sub has_clearer         { defined $_[0]->{'clearer'} }
 sub has_builder         { defined $_[0]->{'builder'} }
 sub has_init_arg        { defined $_[0]->{'init_arg'} }
-sub has_default         { defined $_[0]->{'default'} }
+sub has_default         { exists  $_[0]->{'default'} }
 sub has_initializer     { defined $_[0]->{'initializer'} }
 sub has_insertion_order { defined $_[0]->{'insertion_order'} }
 
diff --git a/t/021_attribute_errors_and_edge_cases.t b/t/021_attribute_errors_and_edge_cases.t
index a6a853d..d00d4c3 100644
--- a/t/021_attribute_errors_and_edge_cases.t
+++ b/t/021_attribute_errors_and_edge_cases.t
@@ -81,6 +81,34 @@ use Class::MOP::Attribute;
         ));
     } '... no default AND builder';
 
+    my $undef_attr;
+    lives_ok {
+        $undef_attr = Class::MOP::Attribute->new('$test' => (
+            default   => undef,
+            predicate => 'has_test',
+        ));
+    } '... undef as a default is okay';
+    ok($undef_attr->has_default, '... and it counts as an actual default');
+    ok(!Class::MOP::Attribute->new('$test')->has_default,
+       '... but attributes with no default have no default');
+
+    Class::MOP::Class->create(
+        'Foo',
+        attributes => [$undef_attr],
+    );
+    {
+        my $obj = Foo->meta->new_object;
+        ok($obj->has_test, '... and the default is populated');
+        is($obj->meta->get_attribute('$test')->get_value($obj), undef, '... with the right value');
+    }
+    lives_ok { Foo->meta->make_immutable }
+             '... and it can be inlined';
+    {
+        my $obj = Foo->new;
+        ok($obj->has_test, '... and the default is populated');
+        is($obj->meta->get_attribute('$test')->get_value($obj), undef, '... with the right value');
+    }
+
 }
 
 
diff --git a/t/316_numeric_defaults.t b/t/316_numeric_defaults.t
new file mode 100755
index 0000000..3050df9
--- /dev/null
+++ b/t/316_numeric_defaults.t
@@ -0,0 +1,125 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+use B;
+use Class::MOP;
+
+my @int_defaults = (
+    100,
+    -2,
+    01234,
+    0xFF,
+);
+
+my @num_defaults = (
+    10.5,
+    -20.0,
+    1e3,
+    1.3e-10,
+);
+
+my @string_defaults = (
+    'foo',
+    '',
+    '100',
+    '10.5',
+    '1e3',
+    '0 but true',
+    '01234',
+    '09876',
+    '0xFF',
+);
+
+for my $default (@int_defaults) {
+    my $copy = $default; # so we can print it out without modifying flags
+    my $attr = Class::MOP::Attribute->new(
+        foo => (default => $default, reader => 'foo'),
+    );
+    my $meta = Class::MOP::Class->create_anon_class(
+        attributes => [$attr],
+        methods    => {bar => sub { $default }},
+    );
+
+    my $obj = $meta->new_object;
+    for my $meth (qw(foo bar)) {
+        my $val = $obj->$meth;
+        my $b = B::svref_2object(\$val);
+        my $flags = $b->FLAGS;
+        ok($flags & B::SVf_IOK || $flags & B::SVp_IOK, "it's an int ($copy)");
+        ok(!($flags & B::SVf_POK), "not a string ($copy)");
+    }
+
+    $meta->make_immutable;
+
+    my $immutable_obj = $meta->name->new;
+    for my $meth (qw(foo bar)) {
+        my $val = $immutable_obj->$meth;
+        my $b = B::svref_2object(\$val);
+        my $flags = $b->FLAGS;
+        ok($flags & B::SVf_IOK || $flags & B::SVp_IOK, "it's an int ($copy) (immutable)");
+        ok(!($flags & B::SVf_POK), "not a string ($copy) (immutable)");
+    }
+}
+
+for my $default (@num_defaults) {
+    my $copy = $default; # so we can print it out without modifying flags
+    my $attr = Class::MOP::Attribute->new(
+        foo => (default => $default, reader => 'foo'),
+    );
+    my $meta = Class::MOP::Class->create_anon_class(
+        attributes => [$attr],
+        methods    => {bar => sub { $default }},
+    );
+
+    my $obj = $meta->new_object;
+    for my $meth (qw(foo bar)) {
+        my $val = $obj->$meth;
+        my $b = B::svref_2object(\$val);
+        my $flags = $b->FLAGS;
+        ok($flags & B::SVf_NOK || $flags & B::SVp_NOK, "it's a num ($copy)");
+        ok(!($flags & B::SVf_POK), "not a string ($copy)");
+    }
+
+    $meta->make_immutable;
+
+    my $immutable_obj = $meta->name->new;
+    for my $meth (qw(foo bar)) {
+        my $val = $immutable_obj->$meth;
+        my $b = B::svref_2object(\$val);
+        my $flags = $b->FLAGS;
+        ok($flags & B::SVf_NOK || $flags & B::SVp_NOK, "it's a num ($copy) (immutable)");
+        ok(!($flags & B::SVf_POK), "not a string ($copy) (immutable)");
+    }
+}
+
+for my $default (@string_defaults) {
+    my $copy = $default; # so we can print it out without modifying flags
+    my $attr = Class::MOP::Attribute->new(
+        foo => (default => $default, reader => 'foo'),
+    );
+    my $meta = Class::MOP::Class->create_anon_class(
+        attributes => [$attr],
+        methods    => {bar => sub { $default }},
+    );
+
+    my $obj = $meta->new_object;
+    for my $meth (qw(foo bar)) {
+        my $val = $obj->$meth;
+        my $b = B::svref_2object(\$val);
+        my $flags = $b->FLAGS;
+        ok($flags & B::SVf_POK, "it's a string ($copy)");
+    }
+
+    $meta->make_immutable;
+
+    my $immutable_obj = $meta->name->new;
+    for my $meth (qw(foo bar)) {
+        my $val = $immutable_obj->$meth;
+        my $b = B::svref_2object(\$val);
+        my $flags = $b->FLAGS;
+        ok($flags & B::SVf_POK, "it's a string ($copy) (immutable)");
+    }
+}
+
+done_testing;