Permalink
Browse files

Implemented basic features.

  • Loading branch information...
1 parent 30ecd7b commit a9a0888762e964bd9e1aa6fc4203390de45bc821 @kentaro committed Sep 26, 2012
Showing with 116 additions and 4 deletions.
  1. +84 −4 lib/Class/Extendable.pm
  2. +32 −0 t/01_extend.t
View
@@ -4,31 +4,111 @@ 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
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
View
@@ -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;

0 comments on commit a9a0888

Please sign in to comment.