Changeset 11209

Timestamp:

05/06/08 19:24:34 (5 years ago)

Author:

yappo

Message:

more Moosenize and add with method

Files:

• lang/perl/Class-Component/trunk/lib/Class/Component/Component/Moosenize.pm (modified) (11 diffs)

lang/perl/Class-Component/trunk/lib/Class/Component/Component/Moosenize.pm

@@ -7 +7 @@
     $class->NEXT( import => %args );
 
+    my $role_pkg   = "$class\::Role";
+    # instasll import method to Plugin base class
+    no strict 'refs';
+    *{"$role_pkg\::import"} = \&{"Class::Component::Component::Moosenize::Implement::inject_import"};
+    unshift @{"$role_pkg\::ISA"}, 'Class::Component::Component::Moosenize::Role';
+
     my $plugin_pkg = "$class\::Plugin";
-    # install Moose like methods to Plugin base class
-    Class::Component::Component::Moosenize::Implement::install_moose_methods($plugin_pkg);
     # install register method or wrapping to Plugin base class
     Class::Component::Component::Moosenize::Implement::install_register_method($plugin_pkg);
-
-    # instasll import method to Plugin base class
-    no strict 'refs';
-    *{"$plugin_pkg\::import"} = \&{"Class::Component::Component::Moosenize::Implement::inject_import"};
 }
 
@@ -25 +25 @@
 
 use Carp::Clan qw/Class::Component/;
+use Class::Inspector;
 use UNIVERSAL::require;
 
 my $requires_map = {};
+my $requires_with_map = {};
 
 sub install_moose_methods {
     my $pkg = shift;
 
-    for my $method (qw/ requires /) {
+    for my $method (qw/ requires with /) {
         no strict 'refs';
         *{"$pkg\::$method"} = sub { unshift @_, $pkg; goto &$method };
@@ -52 +54 @@
         };
     } else {
-        eval "package $pkg;
+        my $code = "package $pkg;
             *register = sub {
                 my \$class = shift;
@@ -60 +62 @@
             };
         ";
-    }
-}
-
+        eval $code;## no critic
+    }
+}
+
+# MyApp::Role->import
 sub inject_import {
     my $class  = shift;
@@ -69 +73 @@
     # instasll Moose like methods to caller class
     install_moose_methods($caller);
-}
-
+    $class->import_after($caller, @_);
+}
+
+# MyApp::Plugin->register
 sub inject_register {
     check_requires(@_);
@@ -79 +85 @@
     my $self = shift;
     my $c    = shift;
-    my $kaller = ref $self || $self;
-    return if $moosenized_cache->{$kaller}++;
+    my $caller = ref $self || $self;
+    return if $moosenized_cache->{$caller}++;
+    return unless $requires_with_map->{$caller};
 
     my @error;
-    for my $class (@{ Class::Component::Implement->isa_list_cache($kaller) }) {
-        next if $kaller eq $class;
-        while (my($method, $attr) = each %{ $requires_map->{$class} }) {
-            my $code = $self->can($method);
-            push @error, sprintf("'%s' requires the method '%s' to be implemented by '%s'", $class, $method, $kaller)
-                unless $code;
-
-            next unless $attr;
-
-            my $attribute = $attr;
-            if (ref $attr) {
-                if (ref $attr eq 'HASH') {
-                    $attribute = delete $attr->{attribute};
-                    $attr = $attr->{args};
+    for my $class (reverse(@{ Class::Component::Implement->isa_list_cache($caller, $caller) }), $caller) {
+
+        my %class_requires; # not role class requires
+        if ($requires_map->{$class} && $caller ne $class) {
+            %class_requires = %{ $requires_map->{$class} };
+        } else {
+            next unless $requires_with_map->{$class};
+        }
+        
+        for my $role (@{ $requires_with_map->{$class} }) {
+            next unless $requires_map->{$role};
+            while (my($method, $attr) = each %{ $requires_map->{$role} }) {
+                if (my $msg = _check_requires($self, $c, $role, $caller, $method, $attr)) {
+                    push @error, $msg;
                 }
-            } else {
-                $attr = undef;
             }
-
-            my $attr_class;
-            if (($attr_class = $attribute) =~ s/^\+//) {
-                $attr_class->require or croak $@;
-            } else {
-                $attr_class = Class::Component::Implement->pkg_require($c => "Attribute::$attribute");
+        }
+
+        while (my($method, $attr) = each %class_requires) {
+            if (my $msg = _check_requires($self, $c, $class, $caller, $method, $attr)) {
+                push @error, $msg;
             }
-
-            $attr_class->register($self, $c, $method, $attr, $code);
         }
     }
     @error and croak join("\n", @error);
 }
+sub _check_requires {
+    my($self, $c, $caller, $role, $method, $attr) = @_;
+
+    my $code = $self->can($method);
+    unless ($code) {
+        return sprintf("'%s' requires the method '%s' to be implemented by '%s'", $role, $method, $caller);
+    }
+    return unless $attr;
+
+    # set attribute
+    my $attributes;
+    if (ref $attr eq 'HASH') {
+        $attributes = [ $attr ]
+    } elsif (ref $attr eq 'ARRAY') {
+        $attributes = $attr;
+    } else {
+        croak 'unimplimented refarence type';
+    }
+
+    # fetch attribute class, value and go
+    for my $data (@{ $attributes }) {
+        my($attribute, $value);
+        if (ref $data eq 'HASH') {
+            ($attribute, $value) = each %{ $data };
+        } else {
+            $attribute = $data;
+        }
+
+        my $attr_class;
+        if (($attr_class = $attribute) =~ s/^\+//) {
+            $attr_class->require or croak $@;
+        } else {
+            $attr_class = Class::Component::Implement->pkg_require($c => "Attribute::$attribute");
+        }
+
+        $attr_class->register($self, $c, $method, $value, $code);
+    }
+
+    return;
+}
+
 
 # moose like methods
@@ -119 +162 @@
 sub requires {
     my $caller = shift;
-    my %methods = @_ == 1 ? ( $_[0] => undef ) : @_;
+    my %methods = (@_ == 1) ? ( $_[0] => undef ) : 
+                            ref $_[1] ? @_ :
+                                      map { $_ => undef } @_;
     my $kaller = ref $caller || $caller;
     $requires_map->{$kaller} ||= {};
@@ -128 +173 @@
 }
 
+sub with {
+    my $caller = shift;
+    my $role   = shift;
+
+    $role->require or croak $@;
+    my %has_methods = map { $_ => 1 } @{ Class::Inspector->functions($caller) };
+    for my $method (@{ Class::Inspector->functions($role) }) {
+        next if $has_methods{$method};
+        no strict 'refs';
+        *{"$caller\::$method"} = *{"$role\::$method"};
+    }
+    $requires_with_map->{$caller} ||= [];
+    push @{ $requires_with_map->{$caller} }, $role;
+}
+
 sub before {
 }
@@ -134 +194 @@
 }
 
+use Data::Dumper;
+
+package # hide pause
+    Class::Component::Component::Moosenize::Role;
+use strict;
+use warnings;
+use Carp::Clan qw/Class::Component/;
+
+sub import_after {}
 1;
 
@@ -147 +216 @@
 =head1 EXPORT METHODS
 
-=ovar 4
-
-=item requires
+=over 4
+
+=item requires, with
 
   package MyApp;
@@ -157 +226 @@
   package MyApp::Plugin;
   use base 'Class::Component::Plugin';
+  use MyApp::Role;
   requires 'foo';
-  requires bar => 'Method', baz => '+Foo::MyAttribute';
-  requires hop => { attribute => 'Method', args => 'jump' };
+  requires bar => ['Method'], baz => ['+Foo::MyAttribute'];
+  requires hop => +{ Method => 'jump' };
+
+  package MyApp::Role;
 
   package MyApp::Role::Blah;
-  use MyApp::Plugin;
+  use MyApp::Role;
   requires 'blah';
 
   package MyApp::Plugin::Hoge;
-  use MyApp::Plugin;
-  use base qw( MyApp::Plugin MyApp::Role::Blah );
+  use base qw( MyApp::Plugin  );
+  use MyApp::Role;
+  with 'MyApp::Role::Blah';
 
   sub foo { # simple method