From: Matt S Trout <mst@shadowcat.co.uk>
Date: Sat, 6 Nov 2010 22:02:10 +0000 (+0000)
Subject: Class::Tiny and refactor _getglob out into _Utils
X-Git-Tag: 0.009001~76
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=6c74d087e1af8d5da762ce9da831a9c6dcca9f7a;p=gitmo%2FRole-Tiny.git

Class::Tiny and refactor _getglob out into _Utils
---

diff --git a/lib/Class/Tiny.pm b/lib/Class/Tiny.pm
new file mode 100644
index 0000000..1bc127c
--- /dev/null
+++ b/lib/Class/Tiny.pm
@@ -0,0 +1,29 @@
+package Class::Tiny;
+
+use strictures 1;
+use Class::Tiny::_Utils;
+
+sub import {
+  my $target = caller;
+  *{_getglob("${target}::extends")} = sub {
+    *{_getglob("${target}::ISA")} = \@_;
+  };
+  *{_getglob("${target}::with")} = sub {
+    require Role::Tiny;
+    die "Only one role supported at a time by with" if @_ > 1;
+    Role::Tiny->apply_role_to_package($_[0], $target);
+  };
+  foreach my $type (qw(before after around)) {
+    *{_getglob "${target}::${type}"} = sub {
+      _install_modifier($target, $type, @_);
+    };
+  }
+  {
+    no strict 'refs';
+    @{"${target}::ISA"} = do {
+      require Class::Tiny::Object; ('Class::Tiny::Object');
+    } unless @{"${target}::ISA"};
+  }
+}
+
+1;
diff --git a/lib/Class/Tiny/Object.pm b/lib/Class/Tiny/Object.pm
new file mode 100644
index 0000000..e3e31c7
--- /dev/null
+++ b/lib/Class/Tiny/Object.pm
@@ -0,0 +1,16 @@
+package Class::Tiny::Object;
+
+use strictures 1;
+
+sub new {
+  my $class = shift;
+  bless({ @_ }, $class);
+}
+
+sub does {
+  require Role::Tiny;
+  { no warnings 'redefine'; *does = \&Role::Tiny::does_role }
+  goto &Role::Tiny::does_role;
+}
+
+1;
diff --git a/lib/Class/Tiny/_Utils.pm b/lib/Class/Tiny/_Utils.pm
new file mode 100644
index 0000000..1131e1e
--- /dev/null
+++ b/lib/Class/Tiny/_Utils.pm
@@ -0,0 +1,20 @@
+package Class::Tiny::_Utils;
+
+use strictures 1;
+use base qw(Exporter);
+
+our @EXPORT = qw(_getglob _install_modifier);
+
+sub _getglob { no strict 'refs'; \*{$_[0]} }
+
+sub _install_modifier {
+  require Class::Method::Modifiers;
+  my ($into, $type, $name, $code) = @_;
+  my $ref = ref(my $to_modify = $into->can($name));
+  if ($ref && $ref =~ /Sub::Defer::Deferred/) {
+    require Sub::Defer; undefer($to_modify);
+  }
+  Class::Method::Modifiers::install_modifier(@_);
+}
+
+1;
diff --git a/lib/Role/Tiny.pm b/lib/Role/Tiny.pm
index 7883099..38ddb82 100644
--- a/lib/Role/Tiny.pm
+++ b/lib/Role/Tiny.pm
@@ -1,13 +1,11 @@
 package Role::Tiny;
 
 use strictures 1;
-use Class::Method::Modifiers ();
+use Class::Tiny::_Utils;
 
 our %INFO;
 our %APPLIED_TO;
 
-sub _getglob { no strict 'refs'; \*{$_[0]} }
-
 sub import {
   my $target = caller;
   # get symbol table reference
@@ -78,7 +76,7 @@ sub apply_role_to_package {
   }
 
   foreach my $modifier (@{$info->{modifiers}||[]}) {
-    Class::Method::Modifiers::install_modifier($to, @{$modifier});
+    _install_modifier($to, @{$modifier});
   }
 
   # only add does() method to classes and only if they don't have one
diff --git a/lib/Sub/Defer.pm b/lib/Sub/Defer.pm
index 11430fa..15f2cee 100644
--- a/lib/Sub/Defer.pm
+++ b/lib/Sub/Defer.pm
@@ -2,13 +2,12 @@ package Sub::Defer;
 
 use strictures 1;
 use base qw(Exporter);
+use Class::Tiny::_Utils;
 
 our @EXPORT = qw(defer undefer);
 
 our %DEFERRED;
 
-sub _getglob { no strict 'refs'; \*{$_[0]} }
-
 sub undefer {
   my ($deferred) = @_;
   my ($target, $maker, $undeferred_ref) = @{
diff --git a/t/class-tiny.t b/t/class-tiny.t
new file mode 100644
index 0000000..85070c3
--- /dev/null
+++ b/t/class-tiny.t
@@ -0,0 +1,78 @@
+use strictures 1;
+use Test::More;
+
+{
+  package MyClass0;
+
+  BEGIN { our @ISA = 'ZeroZero' }
+
+  use Class::Tiny;
+}
+
+BEGIN {
+  is(
+    $INC{'Class/Tiny/Object.pm'}, undef,
+    'Object.pm not loaded if not required'
+  );
+}
+
+{
+  package MyClass1;
+
+  use Class::Tiny;
+}
+
+is_deeply(
+  [ @MyClass1::ISA ], [ 'Class::Tiny::Object' ], 'superclass defaulted'
+);
+
+{
+  package MyClass2;
+
+  use base qw(MyClass1);
+  use Class::Tiny;
+}
+
+is_deeply(
+  [ @MyClass2::ISA ], [ 'MyClass1' ], 'prior superclass left alone'
+);
+
+{
+  package MyClass3;
+
+  use Class::Tiny;
+
+  extends 'MyClass2';
+}
+
+is_deeply(
+  [ @MyClass3::ISA ], [ 'MyClass2' ], 'extends sets superclass'
+);
+
+{
+  package MyClass4;
+
+  use Class::Tiny;
+
+  extends 'WhatTheFlyingFornication';
+
+  extends qw(MyClass2 MyClass3);
+}
+
+is_deeply(
+  [ @MyClass4::ISA ], [ qw(MyClass2 MyClass3) ], 'extends overwrites'
+);
+
+{
+  package MyClass5;
+
+  use Class::Tiny;
+
+  sub foo { 'foo' }
+
+  around foo => sub { my $orig = shift; $orig->(@_).' with around' };
+}
+
+is(MyClass5->foo, 'foo with around', 'method modifier');
+
+done_testing;