From: Matt S Trout <mst@shadowcat.co.uk>
Date: Sun, 7 Nov 2010 10:53:50 +0000 (+0000)
Subject: working lazy default and builder
X-Git-Tag: 0.009001~58
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=46389f86ca7b398a92bbf073c117e2904cc5aa97;p=gitmo%2FRole-Tiny.git

working lazy default and builder
---

diff --git a/lib/Method/Generate/Accessor.pm b/lib/Method/Generate/Accessor.pm
index c9b9dd5..6a0326b 100644
--- a/lib/Method/Generate/Accessor.pm
+++ b/lib/Method/Generate/Accessor.pm
@@ -12,7 +12,7 @@ sub generate_method {
   local $self->{captures} = {};
   my $body = do {
     if ($is eq 'ro') {
-      $self->_generate_get($name)
+      $self->_generate_get($name, $spec)
     } elsif ($is eq 'rw') {
       $self->_generate_getset($name, $spec)
     } else {
@@ -26,8 +26,30 @@ sub generate_method {
 }
 
 sub _generate_get {
-  my ($self, $name) = @_;
-  $self->_generate_simple_get('$_[0]', $name);
+  my ($self, $name, $spec) = @_;
+  my $simple = $self->_generate_simple_get('$_[0]', $name);
+  my ($lazy, $default, $builder) = @{$spec}{qw(lazy default builder)};
+  return $simple unless $lazy and ($default or $builder);
+  'do { '.$self->_generate_default(
+    '$_[0]', $name, $default, $builder,
+    $self->_generate_simple_has('$_[0]', $name),
+  ).'; '.$simple.' }';
+}
+
+sub _generate_simple_has {
+  my ($self, $me, $name) = @_;
+  "exists ${me}->{${\perlstring $name}}";
+}
+
+sub _generate_default {
+  my ($self, $me, $name, $default, $builder, $test) = @_;
+  $self->_generate_simple_set(
+    $me, $name, (
+      $default
+        ? $self->_generate_call_code($name, 'default', $me, $default)
+        : "${me}->${builder}"
+    )
+  ).' unless '.$test;
 }
 
 sub generate_simple_get {
@@ -42,7 +64,7 @@ sub _generate_simple_get {
 
 sub _generate_set {
   my ($self, $name, $value, $spec) = @_;
-  my $simple = $self->_generate_simple_set($name, $value);
+  my $simple = $self->_generate_simple_set('$_[0]', $name, $value);
   my ($trigger, $isa_check) = @{$spec}{qw(trigger isa)};
   return $simple unless $trigger or $isa_check;
   my $code = 'do {';
@@ -105,9 +127,9 @@ sub _generate_call_code {
 }
 
 sub _generate_simple_set {
-  my ($self, $name, $value) = @_;
+  my ($self, $me, $name, $value) = @_;
   my $name_str = perlstring $name;
-  "\$_[0]->{${name_str}} = ${value}";
+  "${me}->{${name_str}} = ${value}";
 }
 
 sub _generate_getset {
diff --git a/lib/Method/Generate/Constructor.pm b/lib/Method/Generate/Constructor.pm
index 8e2b6b8..de3111f 100644
--- a/lib/Method/Generate/Constructor.pm
+++ b/lib/Method/Generate/Constructor.pm
@@ -58,18 +58,28 @@ sub _generate_args {
 
 sub _assign_new {
   my ($self, $spec) = @_;
-  my (@init, @slots);
-  NAME: foreach my $name (keys %$spec) {
+  my (@init, @slots, %test);
+  NAME: foreach my $name (sort keys %$spec) {
     my $attr_spec = $spec->{$name};
-    push @init, do {
-      next NAME unless defined(my $i = $attr_spec->{init_arg});
-      $i;
-    };
+    next NAME unless defined(my $i = $attr_spec->{init_arg});
+    if ($attr_spec->{lazy}) {
+      $test{$name} = $i;
+      next NAME;
+    }
+    push @init, $i;
     push @slots, $name;
   }
   return '' unless @init;
-  '    @{$new}{qw('.join(' ',@slots).')} = @{$args}{qw('.join(' ',@init).')};'
-    ."\n";
+  join '', (
+    @init
+      ? '    @{$new}{qw('.join(' ',@slots).')}'
+        .' = @{$args}{qw('.join(' ',@init).')};'."\n"
+      : ''
+  ), map {
+    my $arg_key = perlstring($test{$_});
+    "    \$new->{${\perlstring($_)}} = \$args->{$arg_key}\n"
+    ."      if exists \$args->{$arg_key};\n"
+  } sort keys %test;
 }
 
 sub _check_required {
diff --git a/t/accessor-default.t b/t/accessor-default.t
new file mode 100644
index 0000000..af6e448
--- /dev/null
+++ b/t/accessor-default.t
@@ -0,0 +1,30 @@
+use strictures 1;
+use Test::More;
+
+{
+  package Foo;
+
+  use Sub::Quote;
+  use Class::Tiny;
+
+  has one => (is => 'ro', lazy => 1, default => quote_sub q{ {} });
+  has two => (is => 'ro', lazy => 1, builder => '_build_two');
+  sub _build_two { {} }
+  has three => (is => 'ro', default => quote_sub q{ {} });
+  has four => (is => 'ro', default => '_build_four');
+  sub _build_four { {} }
+}
+
+sub check {
+  my ($attr, @h) = @_;
+
+  is_deeply($h[$_], {}, "${attr}: empty hashref \$h[$_]") for 0..1;
+
+  isnt($h[0],$h[1], "${attr}: not the same hashref");
+}
+
+check one => map Foo->new->one, 1..2;
+
+check two => map Foo->new->two, 1..2;
+
+done_testing;