Improved subclassing support and added subclass tests

Elimianated the need for caching classes in Net::Twitter; let Moose do it.
semifor · Jun 26, 2009 · 6ffde91 · 6ffde91
1 parent bf9f044
commit 6ffde91
Show file tree

Hide file tree

Showing 2 changed files with 113 additions and 18 deletions.
diff --git a/lib/Net/Twitter.pm b/lib/Net/Twitter.pm
@@ -42,22 +42,19 @@ my $resolve_traits = sub {
     } @traits;
 };
 
-my %ANON_CLASSES;
-
 sub _create_anon_class {
     my ($superclasses, $traits, $immutable) = @_;
 
-    my $cache_key = join '=' => join('|', @$superclasses), join('|', sort @$traits);
-    $ANON_CLASSES{$cache_key} ||= do {
-        my $meta = Net::Twitter::Core->meta->create_anon_class(
-            superclasses => $superclasses,
-            roles        => $traits,
-            cache        => 1,
-        );
-        $meta->add_method(meta => sub { $meta });
-        $meta->make_immutable if $immutable;
-        $meta;
-    };
+    my $meta;
+    $meta = Net::Twitter::Core->meta->create_anon_class(
+        superclasses => $superclasses,
+        roles        => $traits,
+        methods      => { meta => sub { $meta } },
+        cache        => 1,
+    );
+    $meta->make_immutable(inline_constructor => $immutable);
+
+    return $meta;
 }
 
 sub new {
@@ -82,13 +79,15 @@ sub new {
     my $superclasses = [ 'Net::Twitter::Core' ];
     my $meta = _create_anon_class($superclasses, $traits, 1);
 
-    # create a Net::Twitter::Core object
+    # create a Net::Twitter::Core object with roles applied
     my $new = $meta->name->new(%args);
 
-    # rebless it to a subclass, if necessary
-    unshift @$superclasses, $class if $class ne __PACKAGE__;
-    my $final_meta = _create_anon_class($superclasses, $traits, 0);
-    bless $new, $final_meta->name if $meta->name ne $final_meta->name;
+    # rebless it to a subclass wrapper, if necessary
+    if ( $class ne __PACKAGE__ ) {
+        unshift @$superclasses, $class;
+        my $final_meta = _create_anon_class($superclasses, $traits, 0);
+        bless $new, $final_meta->name;
+    }
 
     return $new;
 }

diff --git a/t/15_subclass.t b/t/15_subclass.t
@@ -0,0 +1,96 @@
+#!perl
+use warnings;
+use strict;
+use Test::More tests => 27;
+
+{
+    package My::Subclass::WithNew;
+    use base qw/Net::Twitter/;
+
+    sub new {
+        my $class = shift;
+
+        my $new = $class->SUPER::new(@_);
+        $new->{subclass_attribute} = 'attribute value';
+
+        return $new;
+    }
+
+    sub subclass_method { shift->{subclass_attribute} }
+}
+
+{
+    package My::Subclass::WithoutNew;
+    use base qw/Net::Twitter/;
+
+    sub subclass_method {
+        my $self = shift;
+
+        $self->{subclass_attribute} = shift if @_;
+        return $self->{subclass_attribute};
+    }
+}
+
+{
+    package My::Subclass::WithMoose;
+    use Moose;
+    extends 'Net::Twitter';
+
+    has subclass_attribute => ( is => 'rw', default => 'attribute value' );
+
+    sub subclass_method { shift->subclass_attribute(@_) }
+}
+
+{
+    package My::Subclass::ValidMoose;
+    use Moose;
+    extends 'Net::Twitter::Core';
+
+    with 'Net::Twitter::Role::API::REST';
+
+    has subclass_attribute => ( reader => 'subclass_method', default => 'attribute value' );
+}
+
+diag 'subclass with new';
+my $nt1 = My::Subclass::WithNew->new(username => 'me', password => 'secret');
+isa_ok  $nt1, 'Net::Twitter';
+isa_ok  $nt1, 'Net::Twitter::Core';
+isa_ok  $nt1, 'My::Subclass::WithNew';
+can_ok  $nt1, qw/subclass_method user_timeline search credentials/;
+is      $nt1->subclass_method, 'attribute value', 'has subclass attribute value';
+is      $nt1->password, 'secret', 'has base class attribute value';
+
+diag 'subclass without new';
+my $nt2 = My::Subclass::WithoutNew->new(username => 'me', password => 'secret');
+isa_ok  $nt2, 'Net::Twitter';
+isa_ok  $nt2, 'Net::Twitter::Core';
+isa_ok  $nt2, 'My::Subclass::WithoutNew';
+can_ok  $nt2, qw/subclass_method user_timeline search credentials/;
+is      $nt2->subclass_method('test'), 'test', 'has subclass attribute value';
+is      $nt2->password, 'secret', 'has base class attribute value';
+
+TODO: {
+local $TODO = 'Moose classes should subclass Core, not Net::Twitter';
+diag 'Moose subclass';
+my $nt3 = My::Subclass::WithMoose->new(username => 'me', password => 'secret');
+isa_ok  $nt3, 'Net::Twitter';
+isa_ok  $nt3, 'Net::Twitter::Core';
+isa_ok  $nt3, 'My::Subclass::WithMoose';
+can_ok  $nt3, qw/subclass_method user_timeline search credentials/;
+is      $nt3->subclass_method, 'attribute value', 'has subclass attribute value';
+is      $nt3->password, 'secret', 'has base class attribute value';
+}
+
+diag 'valid Moose subclass';
+my $nt4 = My::Subclass::ValidMoose->new(username => 'me', password => 'secret');
+isa_ok  $nt4, 'Net::Twitter';
+isa_ok  $nt4, 'Net::Twitter::Core';
+isa_ok  $nt4, 'My::Subclass::ValidMoose';
+can_ok  $nt4, qw/subclass_method user_timeline credentials/;
+is      $nt4->subclass_method, 'attribute value', 'has subclass attribute value';
+is      $nt4->password, 'secret', 'has base class attribute value';
+
+diag 'class reuse';
+is      ref $nt1, ref My::Subclass::WithNew->new, 'reused anon class';
+ok      ref $nt1 ne ref $nt2, 'different subclasses have different anon classes';
+ok      ref $nt1 ne ref My::Subclass::WithNew->new(legacy => 0), 'different roles have different classes';