X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FMeta%2FClass.pm;h=36e115ce5656629de007cd88ced5cfb21e846c58;hb=e1d6f0a3c8cee0350b97695a2307af7004a1eb97;hp=20e9b8552b371a050cde543bd3f75acb88fb5bdb;hpb=41419b9e140e4b1b2c7d2de18649151993206509;p=gitmo%2FMoose.git diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm index 20e9b85..36e115c 100644 --- a/lib/Moose/Meta/Class.pm +++ b/lib/Moose/Meta/Class.pm @@ -8,15 +8,16 @@ use Class::MOP; use Carp (); use List::Util qw( first ); -use List::MoreUtils qw( any all ); +use List::MoreUtils qw( any all uniq ); use Scalar::Util 'weaken', 'blessed'; -our $VERSION = '0.57'; +our $VERSION = '0.61'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; use Moose::Meta::Method::Overriden; use Moose::Meta::Method::Augmented; +use Moose::Error::Default; use base 'Class::MOP::Class'; @@ -27,21 +28,17 @@ __PACKAGE__->meta->add_attribute('roles' => ( __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' } -)); - -__PACKAGE__->meta->add_attribute('error_builder' => ( - reader => 'error_builder', - default => 'confess', + default => 'Moose::Meta::Method::Destructor', )); __PACKAGE__->meta->add_attribute('error_class' => ( - reader => 'error_class', + accessor => 'error_class', + default => 'Moose::Error::Default', )); @@ -63,16 +60,27 @@ sub create { (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 { + my $self = shift; + + if ( my @supers = $self->superclasses ) { + $self->_fix_metaclass_incompatibility(@supers); + } + + $self->SUPER::check_metaclass_compatibility(@_); +} + my %ANON_CLASSES; sub create_anon_class { @@ -144,33 +152,31 @@ 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->compute_all_applicable_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} + ), + $attr + ); } + return $self; } @@ -189,74 +195,6 @@ sub construct_instance { return $instance; } -# FIXME: -# This is ugly -sub get_method_map { - 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 - ); - } - - return $map; -} - ### --------------------------------------------- sub add_attribute { @@ -318,10 +256,8 @@ sub _fix_metaclass_incompatibility { . ", it isn't pristine" ); } - return $self->_reconcile_with_superclass_meta($super); + $self->_reconcile_with_superclass_meta($super); } - - return $self; } sub _superclass_meta_is_compatible { @@ -345,14 +281,15 @@ 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 instance_metaclass + constructor_class destructor_class error_class ); sub _reconcile_with_superclass_meta { my ($self, $super) = @_; my $super_meta = $super->meta; - my $super_metaclass_name + my $super_meta_name = $super_meta->is_immutable ? $super_meta->get_mutable_metaclass_name : ref($super_meta); @@ -361,30 +298,37 @@ sub _reconcile_with_superclass_meta { # If neither of these is true we have a more serious # incompatibility that we just cannot fix (yet?). - if ( $super_metaclass_name->isa( ref $self ) + if ( $super_meta_name->isa( ref $self ) && all { $super_meta->$_->isa( $self->$_ ) } @MetaClassTypes ) { - return $self->_reinitialize_with($super_meta); + $self->_reinitialize_with($super_meta); } elsif ( $self->_all_metaclasses_differ_by_roles_only($super_meta) ) { - return $self->_reconcile_role_differences($super_meta); + $self->_reconcile_role_differences($super_meta); } - - return $self; } sub _reinitialize_with { my ( $self, $new_meta ) = @_; - $self = $new_meta->reinitialize( + my $new_self = $new_meta->reinitialize( $self->name, attribute_metaclass => $new_meta->attribute_metaclass, method_metaclass => $new_meta->method_metaclass, instance_metaclass => $new_meta->instance_metaclass, ); - $self->$_( $new_meta->$_ ) for qw( constructor_class destructor_class ); + $new_self->$_( $new_meta->$_ ) + for qw( constructor_class destructor_class error_class ); - return $self; + %$self = %$new_self; + + bless $self, ref $new_self; + + # We need to replace the cached metaclass instance or else when it + # goes out of scope Class::MOP::Class destroy's the namespace for + # the metaclass's class, causing much havoc. + Class::MOP::store_metaclass_by_name( $self->name, $self ); + Class::MOP::weaken_metaclass( $self->name ) if $self->is_anon_class; } # In the more complex case, we share a common ancestor with our @@ -504,7 +448,7 @@ sub _all_roles_until { push @roles, $meta->calculate_all_roles; } - return @roles; + return uniq @roles; } sub _reconcile_role_differences { @@ -529,7 +473,7 @@ sub _reconcile_role_differences { $roles{ $thing . '_roles' } = \@roles; } - $self = $self->_reinitialize_with($super_meta); + $self->_reinitialize_with($super_meta); Moose::Util::MetaRole::apply_metaclass_roles( for_class => $self->name, @@ -552,7 +496,7 @@ sub _process_attribute { @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH'; - if ($name =~ /^\+(.*)/) { + if (($name || '') =~ /^\+(.*)/) { return $self->_process_inherited_attribute($1, @args); } else { @@ -642,13 +586,11 @@ sub make_immutable { ); } -#{ package Moose::Meta::Class::ErrorRoutines; %Carp::Internal? - -our $level; +our $error_level; sub throw_error { my ( $self, @args ) = @_; - local $level = 1; + local $error_level = ($error_level || 0) + 1; $self->raise_error($self->create_error(@args)); } @@ -660,65 +602,28 @@ sub raise_error { sub create_error { my ( $self, @args ) = @_; + require Carp::Heavy; + + local $error_level = ($error_level || 0 ) + 1; + if ( @args % 2 == 1 ) { unshift @args, "message"; } - my %args = ( meta => $self, error => $@, @args ); - - local $level = $level + 1; - - if ( my $class = $args{class} || ( ref $self && $self->error_class ) ) { - return $self->create_error_object( %args, class => $class ); - } else { - my $builder = $args{builder} || ( ref($self) ? $self->error_builder : "confess" ); - - my $builder_method = ( ( ref($builder) && ref($builder) eq 'CODE' ) - ? $builder - : ( $self->can("create_error_$builder") || "create_error_confess" )); + my %args = ( metaclass => $self, last_error => $@, @args ); - return $self->$builder_method(%args); - } -} + $args{depth} += $error_level; -sub create_error_object { - my ( $self, %args ) = @_; + my $class = ref $self ? $self->error_class : "Moose::Error::Default"; - my $class = delete $args{class}; + Class::MOP::load_class($class); $class->new( - %args, - depth => ( ($args{depth} || 1) + ( $level + 1 ) ), + Carp::caller_info($args{depth}), + %args ); } -sub create_error_croak { - my ( $self, @args ) = @_; - $self->_create_error_carpmess( @args ); -} - -sub create_error_confess { - my ( $self, @args ) = @_; - $self->_create_error_carpmess( @args, longmess => 1 ); -} - -sub _create_error_carpmess { - my ( $self, %args ) = @_; - - my $carp_level = $level + 1 + ( $args{depth} || 1 ); - - local $Carp::CarpLevel = $carp_level; # $Carp::CarpLevel + $carp_level ? - local $Carp::MaxArgNums = 20; # default is 8, usually we use named args which gets messier though - - my @args = exists $args{message} ? $args{message} : (); - - if ( $args{longmess} ) { - return Carp::longmess(@args); - } else { - return Carp::shortmess(@args); - } -} - 1; __END__ @@ -838,6 +743,17 @@ 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 + +The name of the class used to throw errors. This default to +L, which generates an error with a stacktrace +just like C. + +=item B + +Moose overrides this method from C and attempts to +fix some incompatibilities before doing the check. + =item B Throws the error created by C using C @@ -858,7 +774,7 @@ Get or set the error builder. Defaults to C. =item B -Get or set the error class. Has no default. +Get or set the error class. This defaults to L. =item B