From: Matt S Trout <mst@shadowcat.co.uk>
Date: Sun, 7 Nov 2010 05:32:07 +0000 (+0000)
Subject: subclassing and role composition for attributes
X-Git-Tag: 0.009001~64
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=96d3f07ac77b846b59a1346c27d991af82cdeba3;p=gitmo%2FRole-Tiny.git

subclassing and role composition for attributes
---

diff --git a/lib/Class/Tiny.pm b/lib/Class/Tiny.pm
index 2e308da..91d6650 100644
--- a/lib/Class/Tiny.pm
+++ b/lib/Class/Tiny.pm
@@ -24,8 +24,19 @@ sub import {
     })->generate_method($target, $name, \%spec);
     ($MAKERS{$target}{constructor} ||= do {
       require Method::Generate::Constructor;
-      Method::Generate::Constructor->new(package => $target)->install_delayed
-    })->register_attribute_spec($name, \%spec);
+      Method::Generate::Constructor
+        ->new(package => $target)
+        ->install_delayed
+        ->register_attribute_specs(do {
+          my @spec;
+          if (my $super = do { no strict 'refs'; ${"${target}::ISA"}[0] }) {
+            if (my $con = $MAKERS{$super}{constructor}) {
+              @spec = %{$con->all_attribute_specs};
+            }
+          }
+          @spec;
+        });
+    })->register_attribute_specs($name, \%spec);
   };
   foreach my $type (qw(before after around)) {
     *{_getglob "${target}::${type}"} = sub {
diff --git a/lib/Method/Generate/Constructor.pm b/lib/Method/Generate/Constructor.pm
index b08385d..41af94e 100644
--- a/lib/Method/Generate/Constructor.pm
+++ b/lib/Method/Generate/Constructor.pm
@@ -5,9 +5,14 @@ use Sub::Quote;
 use base qw(Class::Tiny::Object);
 use Sub::Defer;
 
-sub register_attribute_spec {
-  my ($self, $name, $spec) = @_;
-  $self->{attribute_specs}{$name} = $spec;
+sub register_attribute_specs {
+  my ($self, %spec) = @_;
+  @{$self->{attribute_specs}||={}}{keys %spec} = values %spec;
+  $self;
+}
+
+sub all_attribute_specs {
+  $_[0]->{attribute_specs}
 }
 
 sub install_delayed {
diff --git a/lib/Role/Tiny.pm b/lib/Role/Tiny.pm
index 100622c..b830f64 100644
--- a/lib/Role/Tiny.pm
+++ b/lib/Role/Tiny.pm
@@ -24,6 +24,14 @@ sub import {
     die "Only one role supported at a time by with" if @_ > 1;
     Role::Tiny->apply_role_to_package($_[0], $target);
   };
+  *{_getglob "${target}::has"} = sub {
+    my ($name, %spec) = @_;
+    ($INFO{$target}{accessor_maker} ||= do {
+      require Method::Generate::Accessor;
+      Method::Generate::Accessor->new
+    })->generate_method($target, $name, \%spec);
+    $INFO{$target}{attributes}{$name} = \%spec;
+  };
   # grab all *non-constant* (ref eq 'SCALAR') subs present
   # in the symbol table and store their refaddrs (no need to forcibly
   # inflate constant subs into real subs) - also add '' to here (this
@@ -84,7 +92,29 @@ sub apply_role_to_package {
   if (not $INFO{$to} and not $to->can('does')) {
     ${_getglob "${to}::does"} = \&does_role;
   }
-    
+
+  if (my $attr_info = $info->{attributes}) {
+    if ($INFO{$to}) {
+      @{$INFO{$to}{attributes}||={}}{keys %$attr_info} = values %$attr_info;
+    } else {
+      my $con = $Class::Tiny::MAKERS{$to}{constructor} ||= do {
+        require Method::Generate::Constructor;
+        Method::Generate::Constructor
+          ->new(package => $to)
+          ->install_delayed
+          ->register_attribute_specs(do {
+            my @spec;
+            if (my $super = do { no strict 'refs'; ${"${to}::ISA"}[0] }) {
+              if (my $con = $Class::Tiny::MAKERS{$super}{constructor}) {
+                @spec = %{$con->all_attribute_specs};
+              }
+            }
+            @spec;
+          });
+      };
+      $con->register_attribute_specs(%$attr_info);
+    }
+  }
 
   # copy our role list into the target's
   @{$APPLIED_TO{$to}||={}}{keys %{$APPLIED_TO{$role}}} = ();
diff --git a/t/class-tiny-accessors.t b/t/class-tiny-accessors.t
index 053b01c..3edae8a 100644
--- a/t/class-tiny-accessors.t
+++ b/t/class-tiny-accessors.t
@@ -9,6 +9,22 @@ use Test::More;
   has one => (is => 'ro');
   has two => (is => 'rw', init_arg => undef);
   has three => (is => 'ro', init_arg => 'THREE', required => 1);
+
+  package Bar;
+
+  use Role::Tiny;
+
+  has four => (is => 'ro');
+
+  package Baz;
+
+  use Class::Tiny;
+
+  extends 'Foo';
+
+  with 'Bar';
+
+  has five => (is => 'rw');
 }
 
 my $foo = Foo->new(
@@ -17,7 +33,19 @@ my $foo = Foo->new(
 );
 
 is_deeply(
-  { %$foo }, { one => 1, three => 3 }, 'internals ok'
+  { %$foo }, { one => 1, three => 3 }, 'simple class ok'
+);
+
+my $baz = Baz->new(
+  one => 1,
+  THREE => 3,
+  four => 4,
+  five => 5,
+);
+
+is_deeply(
+  { %$baz }, { one => 1, three => 3, four => 4, five => 5 },
+  'subclass with role ok'
 );
 
 done_testing;