From: Matt S Trout <mst@shadowcat.co.uk>
Date: Sun, 7 Nov 2010 09:06:04 +0000 (+0000)
Subject: factor out sub quote unrolling code, add isa support
X-Git-Tag: 0.009001~59
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=6d377074a6632b1dd9468ee474040047bec31c7a;p=gitmo%2FRole-Tiny.git

factor out sub quote unrolling code, add isa support
---

diff --git a/lib/Method/Generate/Accessor.pm b/lib/Method/Generate/Accessor.pm
index 7814fb8..c9b9dd5 100644
--- a/lib/Method/Generate/Accessor.pm
+++ b/lib/Method/Generate/Accessor.pm
@@ -43,15 +43,22 @@ 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 ($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,21 +70,38 @@ 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    }";
     }
-    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 {
diff --git a/lib/Method/Generate/Constructor.pm b/lib/Method/Generate/Constructor.pm
index 6d45aee..8e2b6b8 100644
--- a/lib/Method/Generate/Constructor.pm
+++ b/lib/Method/Generate/Constructor.pm
@@ -40,6 +40,7 @@ sub generate_method {
   my $body = '    my $class = shift;'."\n";
   $body .= $self->_generate_args;
   $body .= $self->_check_required($spec);
+  $body .= $self->_check_isa($spec);
   $body .= '    my $new = bless({}, $class);'."\n";
   $body .= $self->_assign_new($spec);
   $body .= $self->_fire_triggers($spec);
@@ -76,7 +77,7 @@ sub _check_required {
   my @required_init =
     map $spec->{$_}{init_arg},
       grep $spec->{$_}{required},
-        keys %$spec;
+        sort keys %$spec;
   return '' unless @required_init;
   '    if (my @missing = grep !exists $args->{$_}, qw('
     .join(' ',@required_init).')) {'."\n"
@@ -84,15 +85,30 @@ sub _check_required {
     ."    }\n";
 }
 
+sub _check_isa {
+  my ($self, $spec) = @_;
+  my $acc = $self->accessor_generator;
+  my $captures = $self->{captures};
+  my $check = '';
+  foreach my $name (sort keys %$spec) {
+    my ($init, $isa) = @{$spec->{$name}}{qw(init_arg isa)};
+    next unless $init and $isa;
+    my $init_str = perlstring($init);
+    my ($code, $add_captures) = $acc->generate_isa_check(
+      $name, "\$args->{${init_str}}", $isa
+    );
+    @{$captures}{keys %$add_captures} = values %$add_captures;
+    $check .= "    ${code} if exists \$args->{${init_str}};\n";
+  }
+  return $check;
+}
+
 sub _fire_triggers {
   my ($self, $spec) = @_;
-  my @fire = map {
-    [ $_, $spec->{$_}{init_arg}, $spec->{$_}{trigger} ]
-  } grep { $spec->{$_}{init_arg} && $spec->{$_}{trigger} } keys %$spec;
   my $acc = $self->accessor_generator;
   my $captures = $self->{captures};
   my $fire = '';
-  foreach my $name (keys %$spec) {
+  foreach my $name (sort keys %$spec) {
     my ($init, $trigger) = @{$spec->{$name}}{qw(init_arg trigger)};
     next unless $init && $trigger;
     my ($code, $add_captures) = $acc->generate_trigger(
diff --git a/lib/Sub/Quote.pm b/lib/Sub/Quote.pm
index 72af94e..cd6bff6 100644
--- a/lib/Sub/Quote.pm
+++ b/lib/Sub/Quote.pm
@@ -29,7 +29,8 @@ sub capture_unroll {
 sub _unquote_all_outstanding {
   return unless %QUOTE_OUTSTANDING;
   my ($assembled_code, @assembled_captures, @localize_these) = '';
-  foreach my $outstanding (keys %QUOTE_OUTSTANDING) {
+  # we sort the keys in order to make debugging more predictable
+  foreach my $outstanding (sort keys %QUOTE_OUTSTANDING) {
     my ($name, $code, $captures) = @{$QUOTE_OUTSTANDING{$outstanding}};
 
     push @localize_these, $name if $name;
@@ -107,7 +108,7 @@ sub quote_sub {
 
 sub quoted_from_sub {
   my ($sub) = @_;
-  $QUOTED{$sub};
+  $QUOTED{$sub||''};
 }
 
 sub unquote_sub {
diff --git a/t/accessor-isa.t b/t/accessor-isa.t
new file mode 100644
index 0000000..2e3e9fd
--- /dev/null
+++ b/t/accessor-isa.t
@@ -0,0 +1,80 @@
+use strictures 1;
+use Test::More;
+use Test::Fatal;
+
+sub run_for {
+  my $class = shift;
+
+  my $obj = $class->new(less_than_three => 1);
+
+  is($obj->less_than_three, 1, 'initial value set');
+
+  like(
+    exception { $obj->less_than_three(4) },
+    qr/4 is not less than three/, 'exception thrown on bad set'
+  );
+
+  is($obj->less_than_three, 1, 'initial value remains after bad set');
+
+  my $ret;
+
+  is(
+    exception { $ret = $obj->less_than_three(2) },
+    undef, 'no exception on correct set'
+  );
+
+  is($ret, 2, 'correct setter return');
+  is($obj->less_than_three, 2, 'correct getter return');
+
+  is(exception { $class->new }, undef, 'no exception with no value');
+  like(
+    exception { $class->new(less_than_three => 12) },
+    qr/12 is not less than three/, 'exception thrown on bad constructor arg'
+  );
+}
+
+{
+  package Foo;
+
+  use Class::Tiny;
+
+  has less_than_three => (
+    is => 'rw',
+    isa => sub { die "$_[0] is not less than three" unless $_[0] < 3 }
+  );
+}
+
+run_for 'Foo';
+
+{
+  package Bar;
+
+  use Sub::Quote;
+  use Class::Tiny;
+
+  has less_than_three => (
+    is => 'rw',
+    isa => quote_sub q{ die "$_[0] is not less than three" unless $_[0] < 3 }
+  );
+}
+
+run_for 'Bar';
+
+{
+  package Baz;
+
+  use Sub::Quote;
+  use Class::Tiny;
+
+  has less_than_three => (
+    is => 'rw',
+    isa => quote_sub(
+      q{ die "$_[0] is not less than ${word}" unless $_[0] < $limit },
+      { '$limit' => \3, '$word' => \'three' }
+    )
+  );
+}
+
+run_for 'Baz';
+
+done_testing;