Permalink
Browse files

initial commit

  • Loading branch information...
1 parent 040d58a commit fe96e8ecc283c98dfcdc3221a5c70b62771b8c0f @dann committed Jan 21, 2009
@@ -1,33 +1,135 @@
package MouseX::Object::Pluggable;
-
-use strict;
-use warnings;
+use 5.00800;
our $VERSION = '0.01';
+use Carp ();
+use Mouse::Role;
+use Module::Pluggable::Object;
+use Mouse::Util;
+
+has _plugin_ns => (
+ is => 'rw',
+ required => 1,
+ isa => 'Str',
+ default => sub {'Plugin'},
+);
+
+has _plugin_app_ns => (
+ is => 'rw',
+ required => 1,
+ isa => 'ArrayRef',
+ default => sub { [ ref shift ] },
+);
+
+has _plugin_loaded => (
+ is => 'rw',
+ required => 1,
+ isa => 'HashRef',
+ default => sub { {} }
+);
+
+has _plugin_locator => (
+ is => 'rw',
+ required => 1,
+ lazy => 1,
+ isa => 'Module::Pluggable::Object',
+ clearer => '_clear_plugin_locator',
+ predicate => '_has_plugin_locator',
+ builder => '_build_plugin_locator'
+);
+
+sub load_plugins {
+ my ( $self, @plugins ) = @_;
+ die("You must provide a plugin name") unless @plugins;
+
+ my $loaded = $self->_plugin_loaded;
+ my @load = grep { not exists $loaded->{$_} } @plugins;
+ my @roles = map { $self->_role_from_plugin($_) } @load;
+
+ if ( $self->_load_and_apply_role(@roles) ) {
+ @{$loaded}{@load} = @roles;
+ return 1;
+ }
+ else {
+ return;
+ }
+}
+
+sub load_plugin {
+ my $self = shift;
+ $self->load_plugins(@_);
+}
+
+sub _role_from_plugin {
+ my ( $self, $plugin ) = @_;
+
+ return $1 if ( $plugin =~ /^\+(.*)/ );
+
+ my $o = join '::', $self->_plugin_ns, $plugin;
+
+ #Father, please forgive me for I have sinned.
+ my @roles = grep {/${o}$/} $self->_plugin_locator->plugins;
+
+ Carp::croak("Unable to locate plugin '$plugin'") unless @roles;
+ return $roles[0] if @roles == 1;
+ return shift @roles;
+}
+
+=head2 _load_and_apply_role @roles
+
+Require C<$role> if it is not already loaded and apply it. This is
+the meat of this module.
+
+=cut
+
+sub _load_and_apply_role {
+ my ( $self, @roles ) = @_;
+ die("You must provide a role name") unless @roles;
+
+ foreach my $role (@roles) {
+ eval { Mouse::load_class($role) };
+ confess("Failed to load role: ${role} $@") if $@;
+ }
+ Mouse::Util::apply_all_roles( ( ref $self, @roles ) );
+ return 1;
+}
+
+sub _build_plugin_locator {
+ my $self = shift;
+ my $locator = Module::Pluggable::Object->new(
+ search_path => [
+ map { join '::', ( $_, $self->_plugin_ns ) }
+ @{ $self->_plugin_app_ns }
+ ]
+ );
+ return $locator;
+}
1;
+
__END__
=head1 NAME
-MouseX::Object::Pluggable -
-
-=head1 SYNOPSIS
-
- use MouseX::Object::Pluggable;
+MouseX::Object::Pluggable - Mouse port of MooseX::Object::Pluggable
=head1 DESCRIPTION
-MouseX::Object::Pluggable is
+ Mouse is small memory footprint, so I needed to port
+ MooseX::Object::Pluggable. small memory footprint is very important
+ under some environments.
=head1 AUTHOR
Takatoshi Kitano E<lt>kitano.tk@gmail.comE<gt>
=head1 SEE ALSO
+L<MooseX::Object::Pluggable>,
+
=head1 LICENSE
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut
+
View
@@ -0,0 +1,9 @@
+#!perl
+
+use Test::More tests => 1;
+
+BEGIN {
+ use_ok( 'MouseX::Object::Pluggable' );
+}
+
+diag( "Testing MouseX::Object::Pluggable $MouseX::Object::Pluggable::VERSION, Perl $], $^X" );
View
@@ -0,0 +1,38 @@
+#!/usr/local/bin/perl
+
+use strict;
+use warnings;
+use Test::More;
+use lib 't/lib';
+
+plan tests => 15;
+
+use_ok('TestApp');
+
+my $app = TestApp->new;
+
+is($app->_role_from_plugin('+'.$_), $_)
+ for(qw/MyPrettyPlugin My::Pretty::Plugin/);
+
+is($app->_role_from_plugin($_), 'TestApp::Plugin::'.$_)
+ for(qw/Foo/);
+
+
+
+is( $app->foo, "original foo", 'original foo value');
+is( $app->bar, "original bar", 'original bar value');
+is( $app->bor, "original bor", 'original bor value');
+
+ok($app->load_plugin('Bar'), "Loaded Bar");
+is( $app->bar, "override bar", 'overridden bar via plugin');
+
+ok($app->load_plugin('Baz'), "Loaded Baz");
+is( $app->baz, "plugin baz", 'added baz via plugin');
+
+ok($app->load_plugin('Foo'), "Loaded Foo");
+is( $app->foo, "around foo", 'around foo via plugin');
+
+ok($app->load_plugin('+TestApp::Plugin::Bor'), "Loaded Bor");
+is( $app->bor, "plugin bor", 'override bor via plugin');
+
+#print $app->meta->dump(3);
View
@@ -0,0 +1,34 @@
+#!/usr/local/bin/perl
+
+use strict;
+use warnings;
+use Test::More;
+use lib 't/lib';
+
+plan tests => 15;
+
+use_ok('TestApp2');
+
+my $app = TestApp2->new;
+
+is($app->_role_from_plugin('+'.$_), $_)
+ for(qw/MyPrettyPlugin My::Pretty::Plugin/);
+
+is($app->_role_from_plugin($_), 'TestApp2::Plugin::'.$_)
+ for(qw/Foo/);
+
+is( $app->foo, "original foo", 'original foo value');
+is( $app->bar, "original bar", 'original bar value');
+is( $app->bor, "original bor", 'original bor value');
+
+ok($app->load_plugin('Bar'), "Loaded Bar");
+is( $app->bar, "override bar", 'overridden bar via plugin');
+
+ok($app->load_plugin('Baz'), "Loaded Baz");
+is( $app->baz, "plugin baz", 'added baz via plugin');
+
+ok($app->load_plugin('Foo'), "Loaded Foo");
+is( $app->foo, "around foo 2", 'around foo via plugin');
+
+ok($app->load_plugin('+TestApp::Plugin::Bor'), "Loaded Bor");
+is( $app->bor, "plugin bor", 'override bor via plugin');
View
@@ -0,0 +1,45 @@
+#!/usr/local/bin/perl
+
+use strict;
+use warnings;
+use Test::More;
+use lib 't/lib';
+
+plan tests => 18;
+
+use_ok('TestApp2');
+
+my $app = TestApp2->new;
+
+is($app->_role_from_plugin('+'.$_), $_)
+ for(qw/MyPrettyPlugin My::Pretty::Plugin/);
+
+is($app->_role_from_plugin($_), 'TestApp2::Plugin::'.$_)
+ for(qw/Foo/);
+
+is($app->_role_from_plugin($_), 'TestApp::Plugin::'.$_)
+ for(qw/Bar/);
+
+$app->_plugin_app_ns(['CustomNS', $app->_plugin_app_ns]);
+
+is($app->_role_from_plugin($_), 'CustomNS::Plugin::'.$_)
+ for(qw/Foo/);
+
+is($app->_role_from_plugin($_), 'TestApp::Plugin::'.$_)
+ for(qw/Bar/);
+
+is( $app->foo, "original foo", 'original foo value');
+is( $app->bar, "original bar", 'original bar value');
+is( $app->bor, "original bor", 'original bor value');
+
+ok($app->load_plugin('Bar'), "Loaded Bar");
+is( $app->bar, "override bar", 'overridden bar via plugin');
+
+ok($app->load_plugin('Baz'), "Loaded Baz");
+is( $app->baz, "plugin baz", 'added baz via plugin');
+
+ok($app->load_plugin('Foo'), "Loaded Foo");
+is( $app->foo, "around foo CNS", 'around foo via plugin');
+
+ok($app->load_plugin('+TestApp::Plugin::Bor'), "Loaded Bor");
+is( $app->bor, "plugin bor", 'override bor via plugin');
View
@@ -1,4 +0,0 @@
-use Test::Dependencies
- exclude => [qw/Test::Dependencies Test::Base Test::Perl::Critic MouseX::Object::Pluggable/],
- style => 'light';
-ok_dependencies();
View
@@ -1,5 +0,0 @@
-use strict;
-use Test::More;
-eval { use Test::Perl::Critic -profile => 't/author/perlcriticrc' };
-plan skip_all => "Test::Perl::Critic is not installed." if $@;
-all_critic_ok('lib');
View
@@ -1,4 +0,0 @@
-use Test::More;
-eval "use Test::Pod 1.00";
-plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
-all_pod_files_ok();
View
@@ -0,0 +1,48 @@
+#!perl
+
+use strict;
+use warnings;
+use Test::More tests => 3;
+
+sub not_in_file_ok {
+ my ($filename, %regex) = @_;
+ open my $fh, "<", $filename
+ or die "couldn't open $filename for reading: $!";
+
+ my %violated;
+
+ while (my $line = <$fh>) {
+ while (my ($desc, $regex) = each %regex) {
+ if ($line =~ $regex) {
+ push @{$violated{$desc}||=[]}, $.;
+ }
+ }
+ }
+
+ if (%violated) {
+ fail("$filename contains boilerplate text");
+ diag "$_ appears on lines @{$violated{$_}}" for keys %violated;
+ } else {
+ pass("$filename contains no boilerplate text");
+ }
+}
+
+not_in_file_ok(README =>
+ "The README is used..." => qr/The README is used/,
+ "'version information here'" => qr/to provide version information/,
+);
+
+not_in_file_ok(Changes =>
+ "placeholder date/time" => qr(Date/time)
+);
+
+sub module_boilerplate_ok {
+ my ($module) = @_;
+ not_in_file_ok($module =>
+ 'the great new $MODULENAME' => qr/ - The great new /,
+ 'boilerplate description' => qr/Quick summary of what the module/,
+ 'stub function definition' => qr/function[12]/,
+ );
+}
+
+module_boilerplate_ok('lib/MouseX/Object/Pluggable.pm');
@@ -0,0 +1,9 @@
+package CustomNS::Plugin::Foo;
+
+use strict;
+use warnings;
+use Moose::Role;
+
+around foo => sub{ 'around foo CNS' };
+
+1;
View
@@ -0,0 +1,19 @@
+package TestApp;
+
+use strict;
+use warnings;
+use Moose;
+
+with 'MooseX::Object::Pluggable';
+
+has bee => (is => 'rw', isa => 'Int', required => 1, default => '100');
+
+sub foo{ 'original foo' }
+
+sub bar{ 'original bar' }
+
+sub bor{ 'original bor' }
+
+__PACKAGE__->meta->make_immutable;
+
+1;
@@ -0,0 +1,9 @@
+package TestApp::Plugin::Bar;
+
+use strict;
+use warnings;
+use Moose::Role;
+
+around bar => sub{ 'override bar' };
+
+1;
@@ -0,0 +1,9 @@
+package TestApp::Plugin::Baz;
+
+use strict;
+use warnings;
+use Moose::Role;
+
+sub baz { 'plugin baz' }
+
+1;
@@ -0,0 +1,9 @@
+package TestApp::Plugin::Bor;
+
+use strict;
+use warnings;
+use Moose::Role;
+
+around bor => sub{ 'plugin bor' };
+
+1;
Oops, something went wrong.

0 comments on commit fe96e8e

Please sign in to comment.