X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP%2FClass.pm;h=c87082d65f7336b903f89e9a49ca676243381d8b;hb=52c685d33a36910371f8265346d0030934ba6b95;hp=2e19b9d7b789b92567359a269aa3746b8988a79f;hpb=2a755fe899a935b972c69fddcec98e565ed97177;p=gitmo%2FClass-MOP.git diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index 2e19b9d..c87082d 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.64_05'; +our $VERSION = '0.69'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; @@ -85,7 +85,7 @@ sub construct_class_instance { } # and check the metaclass compatibility - $meta->check_metaclass_compatability(); + $meta->check_metaclass_compatibility(); Class::MOP::store_metaclass_by_name($package_name, $meta); @@ -140,7 +140,7 @@ sub update_package_cache_flag { $self->{'_package_cache_flag'} = Class::MOP::check_package_cache_flag($self->name); } -sub check_metaclass_compatability { +sub check_metaclass_compatibility { my $self = shift; # this is always okay ... @@ -167,14 +167,20 @@ sub check_metaclass_compatability { $class_name . "->meta => (" . ($meta_type) . ")"; # NOTE: # we also need to check that instance metaclasses - # are compatabile in the same the class. + # are compatibile in the same the class. ($self->instance_metaclass->isa($meta->instance_metaclass)) - || confess $self->name . "->meta => (" . ($self->instance_metaclass) . ")" . + || confess $self->name . "->meta->instance_metaclass => (" . ($self->instance_metaclass) . ")" . " is not compatible with the " . - $class_name . "->meta => (" . ($meta->instance_metaclass) . ")"; + $class_name . "->meta->instance_metaclass => (" . ($meta->instance_metaclass) . ")"; } } +# backwards compat for stevan's inability to spell ;) +sub check_metaclass_compatability { + my $self = shift; + $self->check_metaclass_compatibility(@_); +} + ## ANON classes { @@ -212,10 +218,18 @@ sub check_metaclass_compatability { sub DESTROY { my $self = shift; - return if Class::MOP::in_global_destruction; # it'll happen soon anyway and this just makes things more complicated + return if Class::MOP::in_global_destruction(); # it'll happen soon anyway and this just makes things more complicated no warnings 'uninitialized'; return unless $self->name =~ /^$ANON_CLASS_PREFIX/; + # Moose does a weird thing where it replaces the metaclass for + # class when fixing metaclass incompatibility. In that case, + # we don't want to clean out the namespace now. We can detect + # that because Moose will explicitly update the singleton + # cache in Class::MOP. + my $current_meta = Class::MOP::get_metaclass_by_name($self->name); + return if $current_meta ne $self; + my ($serial_id) = ($self->name =~ /^$ANON_CLASS_PREFIX(\d+)/); no strict 'refs'; foreach my $key (keys %{$ANON_CLASS_PREFIX . $serial_id}) { @@ -260,7 +274,16 @@ sub create { eval $code; confess "creation of $package_name failed : $@" if $@; - my $meta = $class->initialize($package_name); + my (%initialize_options) = @args; + delete @initialize_options{qw( + package + superclasses + attributes + methods + version + authority + )}; + my $meta = $class->initialize( $package_name => %initialize_options ); # FIXME totally lame $meta->add_method('meta' => sub { @@ -486,13 +509,22 @@ sub superclasses { if (@_) { my @supers = @_; @{$self->get_package_symbol($var_spec)} = @supers; + + # NOTE: + # on 5.8 and below, we need to call + # a method to get Perl to detect + # a cycle in the class hierarchy + my $class = $self->name; + $class->isa($class); + # NOTE: # we need to check the metaclass # compatibility here so that we can # be sure that the superclass is # not potentially creating an issues # we don't know about - $self->check_metaclass_compatability(); + + $self->check_metaclass_compatibility(); $self->update_meta_instance_dependencies(); } @{$self->get_package_symbol($var_spec)}; @@ -591,15 +623,13 @@ sub class_precedence_list { sub wrap_method_body { my ( $self, %args ) = @_; - my $body = delete $args{body}; # delete is for compat - - ('CODE' eq ref($body)) + ('CODE' eq ref $args{body}) || confess "Your code block must be a CODE reference"; - $self->method_metaclass->wrap( $body => ( + $self->method_metaclass->wrap( package_name => $self->name, %args, - )); + ); } sub add_method { @@ -610,11 +640,7 @@ sub add_method { my $body; if (blessed($method)) { $body = $method->body; - if ($method->package_name ne $self->name && - $method->name ne $method_name) { - warn "Hello there, got something for you." - . " Method says " . $method->package_name . " " . $method->name - . " Class says " . $self->name . " " . $method_name; + if ($method->package_name ne $self->name) { $method = $method->clone( package_name => $self->name, name => $method_name @@ -710,19 +736,9 @@ sub add_method { } sub alias_method { - my ($self, $method_name, $method) = @_; - (defined $method_name && $method_name) - || confess "You must define a method name"; - - my $body = (blessed($method) ? $method->body : $method); - ('CODE' eq ref($body)) - || confess "Your code block must be a CODE reference"; - - $self->add_package_symbol( - { sigil => '&', type => 'CODE', name => $method_name } => $body - ); + my $self = shift; - $self->update_package_cache_flag; # the method map will not list aliased methods + $self->add_method(@_); } sub has_method { @@ -1251,7 +1267,7 @@ to use C once all the bootstrapping is done. This method is used internally by C and should never be called from outside of that method really. -=item B +=item B This method is called as the very last thing in the C method. This will check that the @@ -1461,10 +1477,20 @@ for more information on the method metaclasses. Wrap a code ref (C<$attrs{body>) with C. -=item B +=item B + +This will take a C<$method_name> and CODE reference or meta method +objectand install it into the class's package. -This will take a C<$method_name> and CODE reference to that -C<$method> and install it into the class's package. +You are strongly encouraged to pass a meta method object instead of a +code reference. If you do so, that object gets stored as part of the +class's method map, providing more useful information about the method +for introspection. + +When you provide a method object, this method will clone that object +if the object's package name does not match the class name. This lets +us track the original source of any methods added from other classes +(notably Moose roles). B: This does absolutely nothing special to C<$method> @@ -1472,16 +1498,6 @@ other than use B to make sure it is tagged with the correct name, and therefore show up correctly in stack traces and such. -=item B - -This will take a C<$method_name> and CODE reference to that -C<$method> and alias the method into the class's package. - -B: -Unlike C, this will B try to name the -C<$method> using B, it only aliases the method in -the class's package. - =item B This just provides a simple way to check if the class implements @@ -1569,6 +1585,11 @@ This will return the first method to match a given C<$method_name> in the superclasses, this is basically equivalent to calling C, but it can be dispatched at runtime. +=item B + +B: This method is now deprecated. Just use C +instead. + =back =head2 Method Modifiers