X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FMeta%2FClass.pm;h=a83ee1d069a9b8c298367973e4ca5d3f63c78bd6;hb=eae0508f6f8fca847956c2ed8c48ec23cebd3106;hp=db69521765ac667615ef832634d2cba75b71041d;hpb=bf6fa6b38e130712d35a852315f86edf9a3431f0;p=gitmo%2FMoose.git diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm index db69521..a83ee1d 100644 --- a/lib/Moose/Meta/Class.pm +++ b/lib/Moose/Meta/Class.pm @@ -8,16 +8,19 @@ use Class::MOP; use Carp (); use List::Util qw( first ); -use List::MoreUtils qw( any all ); +use List::MoreUtils qw( any all uniq first_index ); use Scalar::Util 'weaken', 'blessed'; -our $VERSION = '0.57'; +our $VERSION = '0.81'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; -use Moose::Meta::Method::Overriden; +use Moose::Meta::Method::Overridden; use Moose::Meta::Method::Augmented; use Moose::Error::Default; +use Moose::Meta::Class::Immutable::Trait; +use Moose::Meta::Method::Constructor; +use Moose::Meta::Method::Destructor; use base 'Class::MOP::Class'; @@ -26,14 +29,26 @@ __PACKAGE__->meta->add_attribute('roles' => ( default => sub { [] } )); +__PACKAGE__->meta->add_attribute('role_applications' => ( + reader => '_get_role_applications', + default => sub { [] } +)); + +__PACKAGE__->meta->add_attribute( + Class::MOP::Attribute->new('immutable_trait' => ( + accessor => "immutable_trait", + default => 'Moose::Meta::Class::Immutable::Trait', + )) +); + __PACKAGE__->meta->add_attribute('constructor_class' => ( accessor => 'constructor_class', - default => sub { 'Moose::Meta::Method::Constructor' } + default => 'Moose::Meta::Method::Constructor', )); __PACKAGE__->meta->add_attribute('destructor_class' => ( accessor => 'destructor_class', - default => sub { 'Moose::Meta::Method::Destructor' } + default => 'Moose::Meta::Method::Destructor', )); __PACKAGE__->meta->add_attribute('error_class' => ( @@ -41,43 +56,56 @@ __PACKAGE__->meta->add_attribute('error_class' => ( default => 'Moose::Error::Default', )); - sub initialize { my $class = shift; my $pkg = shift; - return Class::MOP::get_metaclass_by_name($pkg) + 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 _immutable_options { + my ( $self, @args ) = @_; + + $self->SUPER::_immutable_options( + inline_destructor => 1, + + # Moose always does this when an attribute is created + inline_accessors => 0, + + @args, + ); } sub create { my ($self, $package_name, %options) = @_; - + (ref $options{roles} eq 'ARRAY') || $self->throw_error("You must pass an ARRAY ref of roles", data => $options{roles}) if exists $options{roles}; + my $roles = delete $options{roles}; my $class = $self->SUPER::create($package_name, %options); - if (exists $options{roles}) { - Moose::Util::apply_all_roles($class, @{$options{roles}}); + if ($roles) { + Moose::Util::apply_all_roles( $class, @$roles ); } - + return $class; } -sub check_metaclass_compatibility { +sub _check_metaclass_compatibility { my $self = shift; if ( my @supers = $self->superclasses ) { $self->_fix_metaclass_incompatibility(@supers); } - $self->SUPER::check_metaclass_compatibility(@_); + $self->SUPER::_check_metaclass_compatibility(@_); } my %ANON_CLASSES; @@ -86,17 +114,17 @@ sub create_anon_class { my ($self, %options) = @_; my $cache_ok = delete $options{cache}; - + # something like Super::Class|Super::Class::2=Role|Role::1 my $cache_key = join '=' => ( - join('|', sort @{$options{superclasses} || []}), - join('|', sort @{$options{roles} || []}), + join('|', @{$options{superclasses} || []}), + join('|', sort @{$options{roles} || []}), ); - + if ($cache_ok && defined $ANON_CLASSES{$cache_key}) { return $ANON_CLASSES{$cache_key}; } - + my $new_class = $self->SUPER::create_anon_class(%options); $ANON_CLASSES{$cache_key} = $new_class @@ -112,6 +140,19 @@ sub add_role { push @{$self->roles} => $role; } +sub role_applications { + my ($self) = @_; + + return @{$self->_get_role_applications}; +} + +sub add_role_application { + my ($self, $application) = @_; + (blessed($application) && $application->isa('Moose::Meta::Role::Application::ToClass')) + || $self->throw_error("Role applications must be instances of Moose::Meta::Role::Application::ToClass", data => $application); + push @{$self->_get_role_applications} => $application; +} + sub calculate_all_roles { my $self = shift; my %seen; @@ -120,11 +161,18 @@ sub calculate_all_roles { sub does_role { my ($self, $role_name) = @_; + (defined $role_name) || $self->throw_error("You must supply a role name to look for"); + foreach my $class ($self->class_precedence_list) { - next unless $class->can('meta') && $class->meta->can('roles'); - foreach my $role (@{$class->meta->roles}) { + my $meta = Class::MOP::class_of($class); + # when a Moose metaclass is itself extended with a role, + # this check needs to be done since some items in the + # class_precedence_list might in fact be Class::MOP + # based still. + next unless $meta && $meta->can('roles'); + foreach my $role (@{$meta->roles}) { return 1 if $role->does_role($role_name); } } @@ -133,17 +181,18 @@ sub does_role { sub excludes_role { my ($self, $role_name) = @_; + (defined $role_name) || $self->throw_error("You must supply a role name to look for"); + foreach my $class ($self->class_precedence_list) { - next unless $class->can('meta'); - # NOTE: - # in the pretty rare instance when a Moose metaclass - # is itself extended with a role, this check needs to - # be done since some items in the class_precedence_list - # might in fact be Class::MOP based still. - next unless $class->meta->can('roles'); - foreach my $role (@{$class->meta->roles}) { + my $meta = Class::MOP::class_of($class); + # when a Moose metaclass is itself extended with a role, + # this check needs to be done since some items in the + # class_precedence_list might in fact be Class::MOP + # based still. + next unless $meta && $meta->can('roles'); + foreach my $role (@{$meta->roles}) { return 1 if $role->excludes_role($role_name); } } @@ -151,117 +200,58 @@ sub excludes_role { } sub new_object { - my $class = shift; + 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}) { - # and if get here, fire the trigger - $attr->trigger->( - $self, - # check if there is a coercion - ($attr->should_coerce - # and if so, we need to grab the - # value that is actually been stored - ? $attr->get_read_method_ref->($self) - # otherwise, just get the value from - # the constructor params - : $params->{$init_arg}), - $attr - ); - } - } - } + my $self = $class->SUPER::new_object($params); + + foreach my $attr ( $class->get_all_attributes() ) { + + next unless $attr->can('has_trigger') && $attr->has_trigger; + + my $init_arg = $attr->init_arg; + + next unless defined $init_arg; + + next unless exists $params->{$init_arg}; + + $attr->trigger->( + $self, + ( + $attr->should_coerce + ? $attr->get_read_method_ref->($self) + : $params->{$init_arg} + ), + ); } + return $self; } -sub construct_instance { +sub _construct_instance { 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 + # but this is foreign inheritance, so we might # have to kludge it in the end. my $instance = $params->{'__INSTANCE__'} || $meta_instance->create_instance(); - foreach my $attr ($class->compute_all_applicable_attributes()) { + foreach my $attr ($class->get_all_attributes()) { $attr->initialize_instance_slot($meta_instance, $instance, $params); } return $instance; } -# FIXME: -# This is ugly -sub get_method_map { +sub superclasses { my $self = shift; - - my $current = Class::MOP::check_package_cache_flag($self->name); - - if (defined $self->{'_package_cache_flag'} && $self->{'_package_cache_flag'} == $current) { - return $self->{'methods'}; - } - - $self->{_package_cache_flag} = $current; - - my $map = $self->{'methods'}; - - my $class_name = $self->name; - my $method_metaclass = $self->method_metaclass; - - my %all_code = $self->get_all_package_symbols('CODE'); - - foreach my $symbol (keys %all_code) { - my $code = $all_code{$symbol}; - - next if exists $map->{$symbol} && - defined $map->{$symbol} && - $map->{$symbol}->body == $code; - - my ($pkg, $name) = Class::MOP::get_code_info($code); - - if ($pkg->can('meta') - # NOTE: - # we don't know what ->meta we are calling - # here, so we need to be careful cause it - # just might blow up at us, or just complain - # loudly (in the case of Curses.pm) so we - # just be a little overly cautious here. - # - SL - && eval { no warnings; blessed($pkg->meta) } - && $pkg->meta->isa('Moose::Meta::Role')) { - #my $role = $pkg->meta->name; - #next unless $self->does_role($role); - } - else { - - # 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, - package_name => $class_name, - name => $symbol - ); + my @supers = @_; + foreach my $super (@supers) { + Class::MOP::load_class($super); + my $meta = Class::MOP::class_of($super); + Moose->throw_error("You cannot inherit from a Moose Role ($super)") + if $meta && $meta->isa('Moose::Meta::Role') } - - return $map; + return $self->SUPER::superclasses(@supers); } ### --------------------------------------------- @@ -270,8 +260,8 @@ sub add_attribute { my $self = shift; $self->SUPER::add_attribute( (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute') - ? $_[0] - : $self->_process_attribute(@_)) + ? $_[0] + : $self->_process_attribute(@_)) ); } @@ -281,7 +271,7 @@ sub add_override_method_modifier { (!$self->has_method($name)) || $self->throw_error("Cannot add an override method if a local method is already present"); - $self->add_method($name => Moose::Meta::Method::Overriden->new( + $self->add_method($name => Moose::Meta::Method::Overridden->new( method => $method, class => $self, package => $_super_package, # need this for roles @@ -307,7 +297,7 @@ sub _find_next_method_by_name_which_is_not_overridden { my ($self, $name) = @_; foreach my $method ($self->find_all_methods_by_name($name)) { return $method->{code} - if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overriden'); + if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overridden'); } return undef; } @@ -316,24 +306,47 @@ sub _fix_metaclass_incompatibility { my ($self, @superclasses) = @_; foreach my $super (@superclasses) { - next if $self->_superclass_meta_is_compatible($super); + my $meta = Class::MOP::Class->initialize($super); + + my @all_supers = $meta->linearized_isa; + shift @all_supers; - unless ( $self->is_pristine ) { - $self->throw_error( - "Cannot attempt to reinitialize metaclass for " - . $self->name - . ", it isn't pristine" ); + my @super_metas_to_fix = ($meta); + + # We need to check & fix the immediate superclass. If its @ISA + # contains a class without a metaclass instance, followed by a + # class _with_ a metaclass instance, init a metaclass instance + # for classes without one and fix compat up to and including + # the class which was already initialized. + my $idx = first_index { Class::MOP::class_of($_) } @all_supers; + + push @super_metas_to_fix, + map { Class::MOP::Class->initialize($_) } @all_supers[ 0 .. $idx ] + if $idx >= 0; + + foreach my $super_meta (@super_metas_to_fix) { + $self->_fix_one_incompatible_metaclass($super_meta); } + } +} + +sub _fix_one_incompatible_metaclass { + my ($self, $meta) = @_; - $self->_reconcile_with_superclass_meta($super); + return if $self->_superclass_meta_is_compatible($meta); + + unless ( $self->is_pristine ) { + $self->throw_error( + "Cannot attempt to reinitialize metaclass for " + . $self->name + . ", it isn't pristine" ); } + + $self->_reconcile_with_superclass_meta($meta); } sub _superclass_meta_is_compatible { - my ($self, $super) = @_; - - my $super_meta = Class::MOP::Class->initialize($super) - or return 1; + my ($self, $super_meta) = @_; next unless $super_meta->isa("Class::MOP::Class"); @@ -350,12 +363,16 @@ sub _superclass_meta_is_compatible { # I don't want to have to type this >1 time my @MetaClassTypes = - qw( attribute_metaclass method_metaclass instance_metaclass constructor_class destructor_class ); + qw( attribute_metaclass + method_metaclass + wrapped_method_metaclass + instance_metaclass + constructor_class + destructor_class + error_class ); sub _reconcile_with_superclass_meta { - my ($self, $super) = @_; - - my $super_meta = $super->meta; + my ($self, $super_meta) = @_; my $super_meta_name = $super_meta->is_immutable @@ -385,7 +402,8 @@ sub _reinitialize_with { instance_metaclass => $new_meta->instance_metaclass, ); - $new_self->$_( $new_meta->$_ ) for qw( constructor_class destructor_class ); + $new_self->$_( $new_meta->$_ ) + for qw( constructor_class destructor_class error_class ); %$self = %$new_self; @@ -446,7 +464,7 @@ sub _find_common_ancestor { # FIXME? This doesn't account for multiple inheritance (not sure # if it needs to though). For example, is somewhere in $meta1's - # history it inherits from both ClassA and ClassB, and $meta + # history it inherits from both ClassA and ClassB, and $meta2 # inherits from ClassB & ClassA, does it matter? And what crazy # fool would do that anyway? @@ -515,13 +533,13 @@ sub _all_roles_until { push @roles, $meta->calculate_all_roles; } - return @roles; + return uniq @roles; } sub _reconcile_role_differences { my ($self, $super_meta) = @_; - my $self_meta = $self->meta; + my $self_meta = Class::MOP::class_of($self); my %roles; @@ -550,20 +568,12 @@ sub _reconcile_role_differences { return $self; } -# NOTE: -# this was crap anyway, see -# Moose::Util::apply_all_roles -# instead -sub _apply_all_roles { - Carp::croak 'DEPRECATED: use Moose::Util::apply_all_roles($meta, @roles) instead' -} - sub _process_attribute { my ( $self, $name, @args ) = @_; @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH'; - if ($name =~ /^\+(.*)/) { + if (($name || '') =~ /^\+(.*)/) { return $self->_process_inherited_attribute($1, @args); } else { @@ -581,7 +591,7 @@ sub _process_inherited_attribute { my ($self, $attr_name, %options) = @_; my $inherited_attr = $self->find_attribute_by_name($attr_name); (defined $inherited_attr) - || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from", data => $attr_name); + || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from in ${\$self->name}", data => $attr_name); if ($inherited_attr->isa('Moose::Meta::Attribute')) { return $inherited_attr->clone_and_inherit_options(%options); } @@ -594,67 +604,6 @@ sub _process_inherited_attribute { ## ------------------------------------------------- -use Moose::Meta::Method::Constructor; -use Moose::Meta::Method::Destructor; - -# This could be done by using SUPER and altering ->options -# I am keeping it this way to make it more explicit. -sub create_immutable_transformer { - my $self = shift; - my $class = Class::MOP::Immutable->new($self, { - read_only => [qw/superclasses/], - cannot_call => [qw/ - add_method - alias_method - remove_method - add_attribute - remove_attribute - remove_package_symbol - add_role - /], - memoize => { - class_precedence_list => 'ARRAY', - linearized_isa => 'ARRAY', # FIXME perl 5.10 memoizes this on its own, no need? - get_all_methods => 'ARRAY', - #get_all_attributes => 'ARRAY', # it's an alias, no need, but maybe in the future - compute_all_applicable_attributes => 'ARRAY', - get_meta_instance => 'SCALAR', - get_method_map => 'SCALAR', - calculate_all_roles => 'ARRAY', - }, - # NOTE: - # this is ugly, but so are typeglobs, - # so whattayahgonnadoboutit - # - SL - wrapped => { - add_package_symbol => sub { - my $original = shift; - $self->throw_error("Cannot add package symbols to an immutable metaclass") - unless (caller(2))[3] eq 'Class::MOP::Package::get_package_symbol'; - goto $original->body; - }, - }, - }); - return $class; -} - -sub make_immutable { - my $self = shift; - $self->SUPER::make_immutable - ( - constructor_class => $self->constructor_class, - destructor_class => $self->destructor_class, - inline_destructor => 1, - # NOTE: - # no need to do this, - # Moose always does it - inline_accessors => 0, - @_, - ); -} - -#{ package Moose::Meta::Class::ErrorRoutines; %Carp::Internal? - our $error_level; sub throw_error { @@ -679,12 +628,14 @@ sub create_error { unshift @args, "message"; } - my %args = ( metaclass => $self, error => $@, @args ); + my %args = ( metaclass => $self, last_error => $@, @args ); $args{depth} += $error_level; my $class = ref $self ? $self->error_class : "Moose::Error::Default"; + Class::MOP::load_class($class); + $class->new( Carp::caller_info($args{depth}), %args @@ -703,157 +654,132 @@ Moose::Meta::Class - The Moose metaclass =head1 DESCRIPTION -This is a subclass of L with Moose specific -extensions. +This class is a subclass of L that provides +additional Moose-specific functionality. -For the most part, the only time you will ever encounter an -instance of this class is if you are doing some serious deep -introspection. To really understand this class, you need to refer -to the L documentation. +To really understand this class, you will need to start with the +L documentation. This class can be understood as a +set of additional features on top of the basic feature provided by +that parent class. + +=head1 INHERITANCE + +C is a subclass of L. =head1 METHODS =over 4 -=item B +=item B<< Moose::Meta::Class->initialize($package_name, %options) >> -=item B +This overrides the parent's method in order to provide its own +defaults for the C, C, and +C options. -Overrides original to accept a list of roles to apply to -the created class. +These all default to the appropriate Moose class. - my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] ); +=item B<< Moose::Meta::Class->create($package_name, %options) >> -=item B +This overrides the parent's method in order to accept a C +option. This should be an array reference containing one more roles +that the class does. -Overrides original to support roles and caching. + my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] ); - my $metaclass = Moose::Meta::Class->create_anon_class( - superclasses => ['Foo'], - roles => [qw/Some Roles Go Here/], - cache => 1, - ); +=item B<< Moose::Meta::Class->create_anon_class >> -=item B +This overrides the parent's method to accept a C option, just +as C does. -Override original to add default options for inlining destructor -and altering the Constructor metaclass. +It also accepts a C option. If this is true, then the anonymous +class will be cached based on its superclasses and roles. If an +existing anonymous class in the cache has the same superclasses and +roles, it will be reused. -=item B + my $metaclass = Moose::Meta::Class->create_anon_class( + superclasses => ['Foo'], + roles => [qw/Some Roles Go Here/], + cache => 1, + ); -Override original to lock C and memoize C +=item B<< $metaclass->make_immutable(%options) >> -=item B +This overrides the parent's method to add a few options. Specifically, +it uses the Moose-specific constructor and destructor classes, and +enables inlining the destructor. -We override this method to support the C attribute option. +Also, since Moose always inlines attributes, it sets the +C option to false. -=item B +=item B<< $metaclass->new_object(%params) >> -This provides some Moose specific extensions to this method, you -almost never call this method directly unless you really know what -you are doing. +This overrides the parent's method in order to add support for +attribute triggers. -This method makes sure to handle the moose weak-ref, type-constraint -and type coercion features. +=item B<< $metaclass->add_override_method_modifier($name, $sub) >> -=item B +This adds an C method modifier to the package. -This accommodates Moose::Meta::Role::Method instances, which are -aliased, instead of added, but still need to be counted as valid -methods. +=item B<< $metaclass->add_augment_method_modifier($name, $sub) >> -=item B +This adds an C method modifier to the package. -This will create an C method modifier for you, and install -it in the package. +=item B<< $metaclass->calculate_all_roles >> -=item B +This will return a unique array of C instances +which are attached to this class. -This will create an C method modifier for you, and install -it in the package. +=item B<< $metaclass->add_role($role) >> -=item B +This takes a L object, and adds it to the class's +list of roles. This I actually apply the role to the class. -=item B +=item B<< $metaclass->role_applications >> -This will return an array of C instances which are -attached to this class. +Returns a list of L +objects, which contain the arguments to role application. -=item B +=item B<< $metaclass->add_role_application($application) >> -This takes an instance of C in C<$role>, and adds it -to the list of associated roles. +This takes a L object, and +adds it to the class's list of role applications. This I +actually apply any role to the class; it is only for tracking role +applications. -=item B +=item B<< $metaclass->does_role($role_name) >> -This will test if this class C a given C<$role_name>. It will -not only check it's local roles, but ask them as well in order to -cascade down the role hierarchy. +This returns a boolean indicating whether or not the class does the +specified role. This tests both the class and its parents. -=item B +=item B<< $metaclass->excludes_role($role_name) >> -This will test if this class C a given C<$role_name>. It will -not only check it's local roles, but ask them as well in order to -cascade down the role hierarchy. +A class excludes a role if it has already composed a role which +excludes the named role. This tests both the class and its parents. -=item B +=item B<< $metaclass->add_attribute($attr_name, %params|$params) >> -This method does the same thing as L, but adds -support for taking the C<$params> as a HASH ref. +This overrides the parent's method in order to allow the parameters to +be provided as a hash reference. -=item B +=item B<< $metaclass->constructor_class ($class_name) >> -=item B +=item B<< $metaclass->destructor_class ($class_name) >> These are the names of classes used when making a class immutable. These default to L and L respectively. These accessors are read-write, so you can use them to change the class name. -=item B +=item B<< $metaclass->error_class($class_name) >> -Moose overrides this method from C and attempts to -fix some incompatibilities before doing the check. +The name of the class used to throw errors. This defaults to +L, which generates an error with a stacktrace +just like C. -=item B +=item B<< $metaclass->throw_error($message, %extra) >> Throws the error created by C using C -=item B - -Creates an error message or object. - -The default behavior is C. - -If C is set uses C. Otherwise uses -C (a code reference or variant name), and calls the appropriate -C method. - -=item B - -Get or set the error builder. Defaults to C. - -=item B - -Get or set the error class. Has no default. - -=item B - -Creates an error using L - -=item B - -Creates an error using L - -=item B - -Calls C on the C parameter in C<%args>. Usable with C -to support custom error objects for your meta class. - -=item B - -Dies with an error object or string. - =back =head1 BUGS @@ -868,7 +794,7 @@ Stevan Little Estevan@iinteractive.comE =head1 COPYRIGHT AND LICENSE -Copyright 2006-2008 by Infinity Interactive, Inc. +Copyright 2006-2009 by Infinity Interactive, Inc. L