also accept hash refs to new_object and friends

[gitmo/Moose.git] / lib / Moose / Meta / Class.pm

diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm
index f113d88..e9670f7 100644 (file)
--- a/lib/Moose/Meta/Class.pm
+++ b/lib/Moose/Meta/Class.pm
@@ -7,9 +7,9 @@ use warnings;
 use Class::MOP;
 
 use Carp         'confess';
-use Scalar::Util 'weaken', 'blessed', 'reftype';
+use Scalar::Util 'weaken', 'blessed';
 
-our $VERSION   = '0.21';
+our $VERSION   = '0.56';
 our $AUTHORITY = 'cpan:STEVAN';
 
 use Moose::Meta::Method::Overriden;
@@ -25,11 +25,13 @@ __PACKAGE__->meta->add_attribute('roles' => (
 sub initialize {
     my $class = shift;
     my $pkg   = shift;
-    $class->SUPER::initialize($pkg,
-        'attribute_metaclass' => 'Moose::Meta::Attribute',
-        'method_metaclass'    => 'Moose::Meta::Method',
-        'instance_metaclass'  => 'Moose::Meta::Instance',
-        @_);
+    return Class::MOP::get_metaclass_by_name($pkg) 
+        || $class->SUPER::initialize($pkg,
+                'attribute_metaclass' => 'Moose::Meta::Attribute',
+                'method_metaclass'    => 'Moose::Meta::Method',
+                'instance_metaclass'  => 'Moose::Meta::Instance',
+                @_
+            );    
 }
 
 sub create {
@@ -119,15 +121,16 @@ sub excludes_role {
 }
 
 sub new_object {
-    my ($class, %params) = @_;
-    my $self = $class->SUPER::new_object(%params);
+    my $class = shift;
+    my $params = @_ == 1 ? $_[0] : {@_};
+    my $self = $class->SUPER::new_object($params);
     foreach my $attr ($class->compute_all_applicable_attributes()) {
         # if we have a trigger, then ...
         if ($attr->can('has_trigger') && $attr->has_trigger) {
             # make sure we have an init-arg ...
             if (defined(my $init_arg = $attr->init_arg)) {
                 # now make sure an init-arg was passes ...
-                if (exists $params{$init_arg}) {
+                if (exists $params->{$init_arg}) {
                     # and if get here, fire the trigger
                     $attr->trigger->(
                         $self, 
@@ -138,7 +141,7 @@ sub new_object {
                             ? $attr->get_read_method_ref->($self)
                             # otherwise, just get the value from
                             # the constructor params
-                            : $params{$init_arg}), 
+                            : $params->{$init_arg}), 
                         $attr
                     );
                 }
@@ -149,15 +152,16 @@ sub new_object {
 }
 
 sub construct_instance {
-    my ($class, %params) = @_;
+    my $class = shift;
+    my $params = @_ == 1 ? $_[0] : {@_};
     my $meta_instance = $class->get_meta_instance;
     # FIXME:
     # the code below is almost certainly incorrect
     # but this is foreign inheritence, so we might
     # have to kludge it in the end.
-    my $instance = $params{'__INSTANCE__'} || $meta_instance->create_instance();
+    my $instance = $params->{'__INSTANCE__'} || $meta_instance->create_instance();
     foreach my $attr ($class->compute_all_applicable_attributes()) {
-        $attr->initialize_instance_slot($meta_instance, $instance, \%params);
+        $attr->initialize_instance_slot($meta_instance, $instance, $params);
     }
     return $instance;
 }
@@ -167,19 +171,23 @@ sub construct_instance {
 sub get_method_map {
     my $self = shift;
 
-    if (defined $self->{'$!_package_cache_flag'} &&
-                $self->{'$!_package_cache_flag'} == Class::MOP::check_package_cache_flag($self->meta->name)) {
-        return $self->{'%!methods'};
+    my $current = Class::MOP::check_package_cache_flag($self->name);
+
+    if (defined $self->{'_package_cache_flag'} && $self->{'_package_cache_flag'} == $current) {
+        return $self->{'methods'};
     }
 
-    my $map  = $self->{'%!methods'};
+    $self->{_package_cache_flag} = $current;
+
+    my $map  = $self->{'methods'};
 
     my $class_name       = $self->name;
     my $method_metaclass = $self->method_metaclass;
 
-    foreach my $symbol ($self->list_all_package_symbols('CODE')) {
+    my %all_code = $self->get_all_package_symbols('CODE');
 
-        my $code = $self->get_package_symbol('&' . $symbol);
+    foreach my $symbol (keys %all_code) {
+        my $code = $all_code{$symbol};
 
         next if exists  $map->{$symbol} &&
                 defined $map->{$symbol} &&
@@ -201,12 +209,26 @@ sub get_method_map {
             #next unless $self->does_role($role);
         }
         else {
-            next if ($pkg  || '') ne $class_name &&
-                    ($name || '') ne '__ANON__';
+            
+            # NOTE:
+            # in 5.10 constant.pm the constants show up 
+            # as being in the right package, but in pre-5.10
+            # they show up as constant::__ANON__ so we 
+            # make an exception here to be sure that things
+            # work as expected in both.
+            # - SL
+            unless ($pkg eq 'constant' && $name eq '__ANON__') {
+                next if ($pkg  || '') ne $class_name ||
+                        (($name || '') ne '__ANON__' && ($pkg  || '') ne $class_name);
+            }
 
         }
 
-        $map->{$symbol} = $method_metaclass->wrap($code);
+        $map->{$symbol} = $method_metaclass->wrap(
+            $code,
+            package_name => $class_name,
+            name         => $symbol
+        );
     }
 
     return $map;
@@ -265,6 +287,7 @@ sub _fix_metaclass_incompatability {
     foreach my $super (@superclasses) {
         # don't bother if it does not have a meta.
         next unless $super->can('meta');
+        next unless $super->meta->isa("Class::MOP::Class");
         # get the name, make sure we take
         # immutable classes into account
         my $super_meta_name = ($super->meta->is_immutable
@@ -359,7 +382,6 @@ sub create_immutable_transformer {
            remove_method
            add_attribute
            remove_attribute
-           add_package_symbol
            remove_package_symbol
            add_role
        /],
@@ -370,7 +392,19 @@ sub create_immutable_transformer {
            get_method_map                    => 'SCALAR',
            # maybe ....
            calculate_all_roles               => 'ARRAY',
-       }
+       },
+       # NOTE:
+       # this is ugly, but so are typeglobs, 
+       # so whattayahgonnadoboutit
+       # - SL
+       wrapped => { 
+           add_package_symbol => sub {
+               my $original = shift;
+               confess "Cannot add package symbols to an immutable metaclass" 
+                   unless (caller(2))[3] eq 'Class::MOP::Package::get_package_symbol'; 
+               goto $original->body;
+           },
+       },       
     });
     return $class;
 }