From a9a0888762e964bd9e1aa6fc4203390de45bc821 Mon Sep 17 00:00:00 2001
From: Kentaro Kuribayashi <kentarok@gmail.com>
Date: Wed, 26 Sep 2012 23:50:59 +0900
Subject: [PATCH] Implemented basic features.

---
 lib/Class/Extendable.pm | 88 +++++++++++++++++++++++++++++++++++++++--
 t/01_extend.t           | 32 +++++++++++++++
 2 files changed, 116 insertions(+), 4 deletions(-)
 create mode 100644 t/01_extend.t

diff --git a/lib/Class/Extendable.pm b/lib/Class/Extendable.pm
index 7fc9f1a..c303baa 100644
--- a/lib/Class/Extendable.pm
+++ b/lib/Class/Extendable.pm
@@ -4,24 +4,98 @@ use warnings;
 use 5.008008;
 our $VERSION = '0.01';
 
+use Carp ();
+use Class::Inspector;
+
+my %SINGLETON_METHODS;
+
+sub import {
+    my ($class) = caller;
+
+    {
+        no strict 'refs';
+
+        *{"$class\::extend"} = sub {
+            my ($self, @classes) = @_;
+            for my $class (@classes) {
+                for my $function (@{Class::Inspector->functions($class) || []}) {
+                    my $code_ref = $class->can($function);
+                    $SINGLETON_METHODS{$self+0}{$function} = $code_ref;
+                }
+            }
+
+            if ($self->can('extended')) {
+                $self->extended(@classes);
+            }
+        };
+
+        my $orig_can = $class->can('can');
+        *{"$class\::can"} = sub {
+            my ($self, $method) = @_;
+            my $code_ref = $SINGLETON_METHODS{$self+0}{$method};
+            return $code_ref if $code_ref;
+            $orig_can->($self, $method);
+        };
+
+        *{"$class\::DESTROY"} = sub {
+            my $self = shift;
+            delete $SINGLETON_METHODS{$self+0};
+        };
+
+        *{"$class\::AUTOLOAD"} = sub {
+            my $self   = shift;
+            my $method = ${"$class\::AUTOLOAD"};
+               $method =~ s/.*:://;
+
+            if (my $code_ref = $SINGLETON_METHODS{$self+0}{$method}) {
+                $code_ref->($self, @_);
+            }
+            else {
+                my $pkg = ref $self;
+                Carp::croak qq(Can't locate object method "$method" via package "$pkg");
+            }
+        }
+    }
+}
+
+!!1;
 
-
-1;
 __END__
 
 =encoding utf8
 
 =head1 NAME
 
-Class::Extendable - blah blah blah
+Class::Extendable - Extendable like Ruby's `singleton method`
 
 =head1 SYNOPSIS
 
+  package My::Foo;
   use Class::Extendable;
+  sub new { bless {}, shift }
+
+  package My::Bar;
+  sub bar {}
+
+  package main;
+  my $obj1 = My::Foo->new;
+  my $obj2 = My::Foo->new;
+
+  ok !$obj1->can('bar');
+  ok !$obj2->can('bar');
+
+  $obj1->extend('My::Bar');
+
+  # Now that `$obj1` extended, it can receive all the methods in `My::Bar`
+  ok $obj1->can('bar');
+  ok !$obj2->can('bar');
 
 =head1 DESCRIPTION
 
-Class::Extendable is
+Class::Extendable provides a feature like Ruby's `singleton
+method`. Once some object is extended with other classes, only that
+object can receive all the methods in those classes, without affecting
+the object's class.
 
 =head1 AUTHOR
 
@@ -29,6 +103,12 @@ Kentaro Kuribayashi E<lt>kentarok@gmail.comE<gt>
 
 =head1 SEE ALSO
 
+= over 4
+
+= item * http://blog.livedoor.jp/dankogai/archives/50484421.html
+
+= back
+
 =head1 LICENSE
 
 Copyright (C) Kentaro Kuribayashi
diff --git a/t/01_extend.t b/t/01_extend.t
new file mode 100644
index 0000000..19d4ec6
--- /dev/null
+++ b/t/01_extend.t
@@ -0,0 +1,32 @@
+use strict;
+use warnings;
+use Test::More;
+
+subtest 'extends object' => sub {
+    my $obj1 = My::Foo->new;
+    my $obj2 = My::Foo->new;
+
+    ok !$obj1->can('bar');
+    ok !$obj2->can('bar');
+
+    $obj1->extend(qw(My::Bar My::Baz));
+
+    ok $obj1->can('bar');
+    ok !$obj2->can('bar');
+    ok $obj1->can('baz');
+    ok !$obj2->can('baz');
+};
+
+package My::Foo;
+use Class::Extendable;
+sub new { bless {}, shift }
+
+package My::Bar;
+sub bar {}
+
+package My::Baz;
+sub baz {}
+
+package main;
+
+done_testing;