support for default at construction time

[gitmo/Role-Tiny.git] / lib / Method / Generate / Accessor.pm

diff --git a/lib/Method/Generate/Accessor.pm b/lib/Method/Generate/Accessor.pm
index 5623366..f922f9c 100644 (file)
--- 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,40 @@ 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_use_default(
+    '$_[0]', $name, $spec,
+    $self->_generate_simple_has('$_[0]', $name),
+  ).'; '.$simple.' }';
+}
+
+sub _generate_simple_has {
+  my ($self, $me, $name) = @_;
+  "exists ${me}->{${\perlstring $name}}";
+}
+
+sub generate_get_default {
+  my $self = shift;
+  local $self->{captures} = {};
+  my $code = $self->_generate_get_default(@_);
+  return ($code, $self->{captures});
+}
+
+sub _generate_use_default {
+  my ($self, $me, $name, $spec, $test) = @_;
+  $self->_generate_simple_set(
+    $me, $name, $self->_generate_get_default($me, $name, $spec)
+  ).' unless '.$test;
+}
+
+sub _generate_get_default {
+  my ($self, $me, $name, $spec) = @_;
+  $spec->{default}
+    ? $self->_generate_call_code($name, 'default', $me, $spec->{default})
+    : "${me}->${\$spec->{builder}}"
 }
 
 sub generate_simple_get {
@@ -42,16 +74,23 @@ sub _generate_simple_get {
 
 sub _generate_set {
   my ($self, $name, $value, $spec) = @_;
-  my $simple = $self->_generate_simple_set($name, $value);
-  if (my $trigger = $spec->{trigger}) {
-    my $value = '$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 {';
+  if ($isa_check) {
+    $code .= ' '.$self->_generate_isa_check($name, '$_[1]', $isa_check).';';
+  }
+  if ($trigger) {
     my $fire = $self->_generate_trigger($name, '$_[0]', '$value', $trigger);
-    return 'do { '
-      .'my $value = '.$simple.'; '.$fire.'; '
-      .'$value }'
-    ;
+    $code .=
+      ' my $value = '.$simple.'; '.$fire.'; '
+      .'$value';
+  } else {
+    $code .= ' '.$simple;
   }
-  return $simple;
+  $code .= ' }';
+  return $code;
 }
 
 sub generate_trigger {
@@ -63,27 +102,51 @@ sub generate_trigger {
 
 sub _generate_trigger {
   my ($self, $name, $obj, $value, $trigger) = @_;
-  if (my $quoted = quoted_from_sub($trigger)) {
+  $self->_generate_call_code($name, 'trigger', "${obj}, ${value}", $trigger);
+}
+
+sub generate_isa_check {
+  my $self = shift;
+  local $self->{captures} = {};
+  my $code = $self->_generate_isa_check(@_);
+  return ($code, $self->{captures});
+}
+
+sub _generate_isa_check {
+  my ($self, $name, $value, $check) = @_;
+  $self->_generate_call_code($name, 'isa_check', $value, $check);
+}
+
+sub _generate_call_code {
+  my ($self, $name, $type, $values, $sub) = @_;
+  if (my $quoted = quoted_from_sub($sub)) {
     my $code = $quoted->[1];
-    my $at_ = 'local @_ = ('.join(', ', $obj, $value).');';
+    my $at_ = 'local @_ = ('.$values.');';
     if (my $captures = $quoted->[2]) {
-      my $cap_name = qq{\$trigger_captures_for_${name}};
+      my $cap_name = qq{\$${type}_captures_for_${name}};
       $self->{captures}->{$cap_name} = \$captures;
       return "do {\n".'      '.$at_."\n"
-       .Sub::Quote::capture_unroll($cap_name, $captures, 6)
-       ."     ${code}\n    }";
+        .Sub::Quote::capture_unroll($cap_name, $captures, 6)
+        ."     ${code}\n    }";
     }
-    return 'do { local @_ = ('.join(', ', $obj, $value).'); '.$code.' }';
+    return 'do { local @_ = ('.$values.'); '.$code.' }';
   }
-  my $cap_name = qq{\$trigger_for_${name}};
-  $self->{captures}->{$cap_name} = \$trigger;
-  return "${cap_name}->(${obj}, ${value})";
+  my $cap_name = qq{\$${type}_for_${name}};
+  $self->{captures}->{$cap_name} = \$sub;
+  return "${cap_name}->(${values})";
+}
+
+sub generate_simple_set {
+  my $self = shift;
+  local $self->{captures} = {};
+  my $code = $self->_generate_simple_set(@_);
+  return ($code, $self->{captures});
 }
 
 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 {