X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FMeta%2FClass.pm;h=ced2a76865c3ef778971cb9e92a729d60dd3d685;hb=50bc108bca305ced4df63a569c9b5f3474f71914;hp=ed252a827458215d3334890634ecd7f575a645f5;hpb=4fb87686e159258937964ab201a092de5d78d508;p=gitmo%2FMoose.git diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm index ed252a8..ced2a76 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.59'; $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,11 +60,12 @@ 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; @@ -154,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; } @@ -353,7 +349,8 @@ 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) = @_; @@ -388,7 +385,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; @@ -518,7 +516,7 @@ sub _all_roles_until { push @roles, $meta->calculate_all_roles; } - return @roles; + return uniq @roles; } sub _reconcile_role_differences { @@ -566,7 +564,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 { @@ -656,13 +654,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)); } @@ -674,65 +670,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 %args = ( metaclass => $self, last_error => $@, @args ); - my $builder_method = ( ( ref($builder) && ref($builder) eq 'CODE' ) - ? $builder - : ( $self->can("create_error_$builder") || "create_error_confess" )); + $args{depth} += $error_level; - return $self->$builder_method(%args); - } -} - -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__ @@ -852,6 +811,12 @@ 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