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=48dd0b6516965b450af1c75a5b54f00319ae8d78;hpb=ae234dc6e9fff0fbe75a405a4de51fd08281e003;p=gitmo%2FClass-MOP.git diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index 48dd0b6..f517a56 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -9,9 +9,9 @@ use Class::MOP::Instance; use Class::MOP::Method::Wrapped; use Carp 'confess'; -use Scalar::Util 'blessed', 'reftype', 'weaken'; +use Scalar::Util 'blessed', 'weaken'; -our $VERSION = '0.32'; +our $VERSION = '0.65'; our $AUTHORITY = 'cpan:STEVAN'; use base 'Class::MOP::Module'; @@ -23,10 +23,8 @@ sub initialize { my $package_name = shift; (defined $package_name && $package_name && !blessed($package_name)) || confess "You must pass a package name and it cannot be blessed"; - if (defined(my $meta = Class::MOP::get_metaclass_by_name($package_name))) { - return $meta; - } - $class->construct_class_instance('package' => $package_name, @_); + return Class::MOP::get_metaclass_by_name($package_name) + || $class->construct_class_instance('package' => $package_name, @_); } sub reinitialize { @@ -76,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 @@ -86,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: @@ -105,7 +103,8 @@ sub construct_class_instance { # we can tell the first time the # methods are fetched # - SL - '$!_package_cache_flag' => undef, + '_package_cache_flag' => undef, + '_meta_instance' => undef, } => $class; } else { @@ -129,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: @@ -138,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 { @@ -227,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" @@ -262,6 +259,7 @@ sub create { my $meta = $class->initialize($package_name); + # FIXME totally lame $meta->add_method('meta' => sub { $class->initialize(blessed($_[0]) || $_[0]); }); @@ -292,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; @@ -349,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 @@ -369,7 +368,7 @@ sub construct_instance { # NOTE: # this will only work for a HASH instance type if ($class->is_anon_class) { - (reftype($instance) eq 'HASH') + (Scalar::Util::reftype($instance) eq 'HASH') || confess "Currently only HASH based instances are supported with instance of anon-classes"; # NOTE: # At some point we should make this official @@ -381,11 +380,26 @@ sub construct_instance { return $instance; } + sub get_meta_instance { - my $class = shift; - return $class->instance_metaclass->new( - $class, - $class->compute_all_applicable_attributes() + my $self = shift; + # NOTE: + # just about any fiddling with @ISA or + # any fiddling with attributes will + # also fiddle with the symbol table + # and therefore invalidate the package + # cache, in which case we should blow + # away the meta-instance cache. Of course + # this will invalidate it more often then + # 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( + associated_metaclass => $self, + attributes => [ $self->compute_all_applicable_attributes() ], ); } @@ -393,7 +407,8 @@ sub clone_object { my $class = shift; my $instance = shift; (blessed($instance) && $instance->isa($class->name)) - || confess "You must pass an instance ($instance) of the metaclass (" . $class->name . ")"; + || confess "You must pass an instance of the metaclass (" . $class->name . "), not ($instance)"; + # NOTE: # we need to protect the integrity of the # Class::MOP::Class singletons here, they @@ -405,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()) { @@ -461,10 +476,11 @@ sub rebless_instance { # Inheritance sub superclasses { - my $self = shift; + my $self = shift; + my $var_spec = { sigil => '@', type => 'ARRAY', name => 'ISA' }; if (@_) { my @supers = @_; - @{$self->get_package_symbol('@ISA')} = @supers; + @{$self->get_package_symbol($var_spec)} = @supers; # NOTE: # we need to check the metaclass # compatibility here so that we can @@ -473,7 +489,7 @@ sub superclasses { # we don't know about $self->check_metaclass_compatability(); } - @{$self->get_package_symbol('@ISA')}; + @{$self->get_package_symbol($var_spec)}; } sub subclasses { @@ -571,7 +587,7 @@ sub add_method { $body = $method->body; if ($method->package_name ne $self->name && $method->name ne $method_name) { - warn "Hello there, got somethig for you." + warn "Hello there, got something for you." . " Method says " . $method->package_name . " " . $method->name . " Class says " . $self->name . " " . $method_name; $method = $method->clone( @@ -582,7 +598,7 @@ sub add_method { } else { $body = $method; - ('CODE' eq (reftype($body) || '')) + ('CODE' eq ref($body)) || confess "Your code block must be a CODE reference"; $method = $self->method_metaclass->wrap( $body => ( @@ -594,7 +610,8 @@ sub add_method { $self->get_method_map->{$method_name} = $method; my $full_method_name = ($self->name . '::' . $method_name); - $self->add_package_symbol("&${method_name}" => + $self->add_package_symbol( + { sigil => '&', type => 'CODE', name => $method_name }, Class::MOP::subname($full_method_name => $body) ); $self->update_package_cache_flag; @@ -676,10 +693,12 @@ sub alias_method { || confess "You must define a method name"; my $body = (blessed($method) ? $method->body : $method); - ('CODE' eq (reftype($body) || '')) + ('CODE' eq ref($body)) || confess "Your code block must be a CODE reference"; - $self->add_package_symbol("&${method_name}" => $body); + $self->add_package_symbol( + { sigil => '&', type => 'CODE', name => $method_name } => $body + ); $self->update_package_cache_flag; } @@ -713,7 +732,9 @@ sub remove_method { my $removed_method = delete $self->get_method_map->{$method_name}; - $self->remove_package_symbol("&${method_name}"); + $self->remove_package_symbol( + { sigil => '&', type => 'CODE', name => $method_name } + ); $self->update_package_cache_flag; @@ -902,16 +923,36 @@ sub is_immutable { 0 } # the reference stored in $IMMUTABLE_TRANSFORMERS{$class} and ||= should DWIM { + my %IMMUTABLE_TRANSFORMERS; my %IMMUTABLE_OPTIONS; + + sub get_immutable_options { + my $self = shift; + return if $self->is_mutable; + confess "unable to find immutabilizing options" + unless exists $IMMUTABLE_OPTIONS{$self->name}; + my %options = %{$IMMUTABLE_OPTIONS{$self->name}}; + delete $options{IMMUTABLE_TRANSFORMER}; + return \%options; + } + + sub get_immutable_transformer { + my $self = shift; + if( $self->is_mutable ){ + my $class = blessed $self || $self; + return $IMMUTABLE_TRANSFORMERS{$class} ||= $self->create_immutable_transformer; + } + confess "unable to find transformer for immutable class" + unless exists $IMMUTABLE_OPTIONS{$self->name}; + return $IMMUTABLE_OPTIONS{$self->name}->{IMMUTABLE_TRANSFORMER}; + } + sub make_immutable { my $self = shift; my %options = @_; - my $class = blessed $self || $self; - - $IMMUTABLE_TRANSFORMERS{$class} ||= $self->create_immutable_transformer; - my $transformer = $IMMUTABLE_TRANSFORMERS{$class}; + my $transformer = $self->get_immutable_transformer; $transformer->make_metaclass_immutable($self, \%options); $IMMUTABLE_OPTIONS{$self->name} = { %options, IMMUTABLE_TRANSFORMER => $transformer }; @@ -920,7 +961,7 @@ sub is_immutable { 0 } print STDERR "# of Metaclass options: ", keys %IMMUTABLE_OPTIONS; print STDERR "# of Immutable transformers: ", keys %IMMUTABLE_TRANSFORMERS; } - + 1; } @@ -1566,6 +1607,15 @@ the L documentation. This method will reverse tranforamtion upon the class which made it immutable. +=item B + +Return a transformer suitable for making this class immutable or, if this +class is immutable, the transformer used to make it immutable. + +=item B + +If the class is immutable, return the options used to make it immutable. + =item B Create a transformer suitable for making this class immutable