X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP%2FClass.pm;h=f517a56c721f131694be98eb827aa950aed27ce5;hb=9c71cbf7f162ca9848f7243a0f2c3d3241817e30;hp=050189ba6e7eca4ae23b6428ea656b8844b0b6ca;hpb=f3e2012935ea96dc1846cb9ba577cb6931bf43fb;p=gitmo%2FClass-MOP.git diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index 050189b..f517a56 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -11,7 +11,7 @@ use Class::MOP::Method::Wrapped; use Carp 'confess'; use Scalar::Util 'blessed', 'weaken'; -our $VERSION = '0.63'; +our $VERSION = '0.65'; our $AUTHORITY = 'cpan:STEVAN'; use base 'Class::MOP::Module'; @@ -74,7 +74,7 @@ sub construct_class_instance { no strict 'refs'; $meta = bless { # inherited from Class::MOP::Package - '$!package' => $package_name, + 'package' => $package_name, # NOTE: # since the following attributes will @@ -84,18 +84,18 @@ sub construct_class_instance { # listed here for reference, because they # should not actually have a value associated # with the slot. - '%!namespace' => \undef, + 'namespace' => \undef, # inherited from Class::MOP::Module - '$!version' => \undef, - '$!authority' => \undef, + 'version' => \undef, + 'authority' => \undef, # defined in Class::MOP::Class - '@!superclasses' => \undef, + 'superclasses' => \undef, - '%!methods' => {}, - '%!attributes' => {}, - '$!attribute_metaclass' => $options{'attribute_metaclass'} || 'Class::MOP::Attribute', - '$!method_metaclass' => $options{'method_metaclass'} || 'Class::MOP::Method', - '$!instance_metaclass' => $options{'instance_metaclass'} || 'Class::MOP::Instance', + 'methods' => {}, + 'attributes' => {}, + 'attribute_metaclass' => $options{'attribute_metaclass'} || 'Class::MOP::Attribute', + 'method_metaclass' => $options{'method_metaclass'} || 'Class::MOP::Method', + 'instance_metaclass' => $options{'instance_metaclass'} || 'Class::MOP::Instance', ## uber-private variables # NOTE: @@ -103,8 +103,8 @@ sub construct_class_instance { # we can tell the first time the # methods are fetched # - SL - '$!_package_cache_flag' => undef, - '$!_meta_instance' => undef, + '_package_cache_flag' => undef, + '_meta_instance' => undef, } => $class; } else { @@ -128,7 +128,7 @@ sub construct_class_instance { $meta; } -sub reset_package_cache_flag { (shift)->{'$!_package_cache_flag'} = undef } +sub reset_package_cache_flag { (shift)->{'_package_cache_flag'} = undef } sub update_package_cache_flag { my $self = shift; # NOTE: @@ -137,7 +137,7 @@ sub update_package_cache_flag { # to our cache as well. This avoids us # having to regenerate the method_map. # - SL - $self->{'$!_package_cache_flag'} = Class::MOP::check_package_cache_flag($self->name); + $self->{'_package_cache_flag'} = Class::MOP::check_package_cache_flag($self->name); } sub check_metaclass_compatability { @@ -226,17 +226,15 @@ sub check_metaclass_compatability { # creating classes with MOP ... sub create { - my $class = shift; - my $package_name = shift; + my ( $class, @args ) = @_; - (defined $package_name && $package_name) - || confess "You must pass a package name"; + unshift @args, 'name' if @args % 2 == 1; - (scalar @_ % 2 == 0) - || confess "You much pass all parameters as name => value pairs " . - "(I found an uneven number of params in \@_)"; + my (%options) = @args; + my $package_name = $options{name}; - my (%options) = @_; + (defined $package_name && $package_name) + || confess "You must pass a package name"; (ref $options{superclasses} eq 'ARRAY') || confess "You must pass an ARRAY ref of superclasses" @@ -261,6 +259,7 @@ sub create { my $meta = $class->initialize($package_name); + # FIXME totally lame $meta->add_method('meta' => sub { $class->initialize(blessed($_[0]) || $_[0]); }); @@ -291,22 +290,22 @@ sub create { # all these attribute readers will be bootstrapped # away in the Class::MOP bootstrap section -sub get_attribute_map { $_[0]->{'%!attributes'} } -sub attribute_metaclass { $_[0]->{'$!attribute_metaclass'} } -sub method_metaclass { $_[0]->{'$!method_metaclass'} } -sub instance_metaclass { $_[0]->{'$!instance_metaclass'} } +sub get_attribute_map { $_[0]->{'attributes'} } +sub attribute_metaclass { $_[0]->{'attribute_metaclass'} } +sub method_metaclass { $_[0]->{'method_metaclass'} } +sub instance_metaclass { $_[0]->{'instance_metaclass'} } # FIXME: # this is a prime canidate for conversion to XS sub get_method_map { my $self = shift; - if (defined $self->{'$!_package_cache_flag'} && - $self->{'$!_package_cache_flag'} == Class::MOP::check_package_cache_flag($self->name)) { - return $self->{'%!methods'}; + if (defined $self->{'_package_cache_flag'} && + $self->{'_package_cache_flag'} == Class::MOP::check_package_cache_flag($self->name)) { + return $self->{'methods'}; } - my $map = $self->{'%!methods'}; + my $map = $self->{'methods'}; my $class_name = $self->name; my $method_metaclass = $self->method_metaclass; @@ -348,6 +347,7 @@ sub get_method_map { sub new_object { my $class = shift; + # NOTE: # we need to protect the integrity of the # Class::MOP::Class singletons here, so we @@ -394,12 +394,12 @@ sub get_meta_instance { # is probably needed, but better safe # then sorry. # - SL - $self->{'$!_meta_instance'} = undef - if defined $self->{'$!_package_cache_flag'} && - $self->{'$!_package_cache_flag'} == Class::MOP::check_package_cache_flag($self->name); - $self->{'$!_meta_instance'} ||= $self->instance_metaclass->new( - $self, - $self->compute_all_applicable_attributes() + $self->{'_meta_instance'} = undef + if defined $self->{'_package_cache_flag'} && + $self->{'_package_cache_flag'} == Class::MOP::check_package_cache_flag($self->name); + $self->{'_meta_instance'} ||= $self->instance_metaclass->new( + associated_metaclass => $self, + attributes => [ $self->compute_all_applicable_attributes() ], ); } @@ -420,7 +420,7 @@ sub clone_object { sub clone_instance { my ($class, $instance, %params) = @_; (blessed($instance)) - || confess "You can only clone instances, \$self is not a blessed instance"; + || confess "You can only clone instances, ($instance) is not a blessed instance"; my $meta_instance = $class->get_meta_instance(); my $clone = $meta_instance->clone_instance($instance); foreach my $attr ($class->compute_all_applicable_attributes()) {