diff options
Diffstat (limited to 'lib/Moose/Meta')
121 files changed, 16112 insertions, 0 deletions
diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm new file mode 100644 index 0000000..0c91693 --- /dev/null +++ b/lib/Moose/Meta/Attribute.pm @@ -0,0 +1,1734 @@ +use strict; +use warnings; +package Moose::Meta::Attribute; +our $VERSION = '2.1405'; + +use B (); +use Scalar::Util 'blessed'; +use List::Util 1.33 'any'; +use Try::Tiny; +use overload (); + +use Moose::Deprecated; +use Moose::Meta::Method::Accessor; +use Moose::Meta::Method::Delegation; +use Moose::Util 'throw_exception'; +use Moose::Util::TypeConstraints (); +use Class::MOP::MiniTrait; + +use parent 'Class::MOP::Attribute', 'Moose::Meta::Mixin::AttributeCore'; + +use Carp 'confess'; + +Class::MOP::MiniTrait::apply(__PACKAGE__, 'Moose::Meta::Object::Trait'); + +__PACKAGE__->meta->add_attribute('traits' => ( + reader => 'applied_traits', + predicate => 'has_applied_traits', + Class::MOP::_definition_context(), +)); + +# we need to have a ->does method in here to +# more easily support traits, and the introspection +# of those traits. We extend the does check to look +# for metatrait aliases. +sub does { + my ($self, $role_name) = @_; + my $name = try { + Moose::Util::resolve_metatrait_alias(Attribute => $role_name) + }; + return 0 if !defined($name); # failed to load class + return $self->Moose::Object::does($name); +} + +sub _inline_throw_exception { + my ( $self, $exception_type, $throw_args ) = @_; + return 'die Module::Runtime::use_module("Moose::Exception::' . $exception_type . '")->new(' . ($throw_args || '') . ')'; +} + +sub new { + my ($class, $name, %options) = @_; + $class->_process_options($name, \%options) unless $options{__hack_no_process_options}; # used from clone()... YECHKKK FIXME ICKY YUCK GROSS + + delete $options{__hack_no_process_options}; + + my %attrs = + ( map { $_ => 1 } + grep { defined } + map { $_->init_arg() } + $class->meta()->get_all_attributes() + ); + + my @bad = sort grep { ! $attrs{$_} } keys %options; + + if (@bad) + { + my $s = @bad > 1 ? 's' : ''; + my $list = join "', '", @bad; + + my $package = $options{definition_context}{package}; + my $context = $options{definition_context}{context} + || 'attribute constructor'; + my $type = $options{definition_context}{type} || 'class'; + + my $location = ''; + if (defined($package)) { + $location = " in "; + $location .= "$type " if $type; + $location .= $package; + } + + Carp::cluck "Found unknown argument$s '$list' in the $context for '$name'$location"; + } + + return $class->SUPER::new($name, %options); +} + +sub interpolate_class_and_new { + my $class = shift; + my $name = shift; + + throw_exception( MustPassEvenNumberOfAttributeOptions => attribute_name => $name, + options => \@_ + ) + if @_ % 2 == 1; + + my %args = @_; + + my ( $new_class, @traits ) = $class->interpolate_class(\%args); + $new_class->new($name, %args, ( scalar(@traits) ? ( traits => \@traits ) : () ) ); +} + +sub interpolate_class { + my ($class, $options) = @_; + + $class = ref($class) || $class; + + if ( my $metaclass_name = delete $options->{metaclass} ) { + my $new_class = Moose::Util::resolve_metaclass_alias( Attribute => $metaclass_name ); + + if ( $class ne $new_class ) { + if ( $new_class->can("interpolate_class") ) { + return $new_class->interpolate_class($options); + } else { + $class = $new_class; + } + } + } + + my @traits; + + if (my $traits = $options->{traits}) { + my $i = 0; + my $has_foreign_options = 0; + + while ($i < @$traits) { + my $trait = $traits->[$i++]; + next if ref($trait); # options to a trait we discarded + + $trait = Moose::Util::resolve_metatrait_alias(Attribute => $trait) + || $trait; + + next if $class->does($trait); + + push @traits, $trait; + + # are there options? + if ($traits->[$i] && ref($traits->[$i])) { + $has_foreign_options = 1 + if any { $_ ne '-alias' && $_ ne '-excludes' } keys %{ $traits->[$i] }; + + push @traits, $traits->[$i++]; + } + } + + if (@traits) { + my %options = ( + superclasses => [ $class ], + roles => [ @traits ], + ); + + if ($has_foreign_options) { + $options{weaken} = 0; + } + else { + $options{cache} = 1; + } + + my $anon_class = Moose::Meta::Class->create_anon_class(%options); + $class = $anon_class->name; + } + } + + return ( wantarray ? ( $class, @traits ) : $class ); +} + +# ... + +# method-generating options shouldn't be overridden +sub illegal_options_for_inheritance { + qw(reader writer accessor clearer predicate) +} + +# NOTE/TODO +# This method *must* be able to handle +# Class::MOP::Attribute instances as +# well. Yes, I know that is wrong, but +# apparently we didn't realize it was +# doing that and now we have some code +# which is dependent on it. The real +# solution of course is to push this +# feature back up into Class::MOP::Attribute +# but I not right now, I am too lazy. +# However if you are reading this and +# looking for something to do,.. please +# be my guest. +# - stevan +sub clone_and_inherit_options { + my ($self, %options) = @_; + + # NOTE: + # we may want to extends a Class::MOP::Attribute + # in which case we need to be able to use the + # core set of legal options that have always + # been here. But we allows Moose::Meta::Attribute + # instances to changes them. + # - SL + my @illegal_options = $self->can('illegal_options_for_inheritance') + ? $self->illegal_options_for_inheritance + : (); + + my @found_illegal_options = grep { exists $options{$_} && exists $self->{$_} ? $_ : undef } @illegal_options; + (scalar @found_illegal_options == 0) + || throw_exception( IllegalInheritedOptions => illegal_options => \@found_illegal_options, + params => \%options + ); + + $self->_process_isa_option( $self->name, \%options ); + $self->_process_does_option( $self->name, \%options ); + + # NOTE: + # this doesn't apply to Class::MOP::Attributes, + # so we can ignore it for them. + # - SL + if ($self->can('interpolate_class')) { + ( $options{metaclass}, my @traits ) = $self->interpolate_class(\%options); + + my %seen; + my @all_traits = grep { $seen{$_}++ } @{ $self->applied_traits || [] }, @traits; + $options{traits} = \@all_traits if @all_traits; + } + + # This method can be called on a CMOP::Attribute object, so we need to + # make sure we can call this method. + $self->_process_lazy_build_option( $self->name, \%options ) + if $self->can('_process_lazy_build_option'); + + $self->clone(%options); +} + +sub clone { + my ( $self, %params ) = @_; + + my $class = delete $params{metaclass} || ref $self; + + my ( @init, @non_init ); + + foreach my $attr ( grep { $_->has_value($self) } Class::MOP::class_of($self)->get_all_attributes ) { + push @{ $attr->has_init_arg ? \@init : \@non_init }, $attr; + } + + my %new_params = ( ( map { $_->init_arg => $_->get_value($self) } @init ), %params ); + + my $name = delete $new_params{name}; + + my $clone = $class->new($name, %new_params, __hack_no_process_options => 1 ); + + foreach my $attr ( @non_init ) { + $attr->set_value($clone, $attr->get_value($self)); + } + + return $clone; +} + +sub _process_options { + my ( $class, $name, $options ) = @_; + + $class->_process_is_option( $name, $options ); + $class->_process_isa_option( $name, $options ); + $class->_process_does_option( $name, $options ); + $class->_process_coerce_option( $name, $options ); + $class->_process_trigger_option( $name, $options ); + $class->_process_auto_deref_option( $name, $options ); + $class->_process_lazy_build_option( $name, $options ); + $class->_process_lazy_option( $name, $options ); + $class->_process_required_option( $name, $options ); +} + +sub _process_is_option { + my ( $class, $name, $options ) = @_; + + return unless $options->{is}; + + ### ------------------------- + ## is => ro, writer => _foo # turns into (reader => foo, writer => _foo) as before + ## is => rw, writer => _foo # turns into (reader => foo, writer => _foo) + ## is => rw, accessor => _foo # turns into (accessor => _foo) + ## is => ro, accessor => _foo # error, accesor is rw + ### ------------------------- + + if ( $options->{is} eq 'ro' ) { + throw_exception("AccessorMustReadWrite" => attribute_name => $name, + params => $options, + ) + if exists $options->{accessor}; + $options->{reader} ||= $name; + } + elsif ( $options->{is} eq 'rw' ) { + if ( $options->{writer} ) { + $options->{reader} ||= $name; + } + else { + $options->{accessor} ||= $name; + } + } + elsif ( $options->{is} eq 'bare' ) { + return; + # do nothing, but don't complain (later) about missing methods + } + else { + throw_exception( InvalidValueForIs => attribute_name => $name, + params => $options, + ); + } +} + +sub _process_isa_option { + my ( $class, $name, $options ) = @_; + + return unless exists $options->{isa}; + + if ( exists $options->{does} ) { + if ( try { $options->{isa}->can('does') } ) { + ( $options->{isa}->does( $options->{does} ) ) + || throw_exception( IsaDoesNotDoTheRole => attribute_name => $name, + params => $options, + ); + } + else { + throw_exception( IsaLacksDoesMethod => attribute_name => $name, + params => $options, + ); + } + } + + # allow for anon-subtypes here ... + # + # Checking for Specio explicitly is completely revolting. At some point + # this needs to be refactored so that Moose core defines a standard type + # API that all types must implement. Unfortunately, the current core API + # is _not_ the right API, so we probably need to A) come up with the new + # API (Specio is a good start); B) refactor the core types to implement + # that API; C) do duck type checking on type objects. + if ( blessed( $options->{isa} ) + && $options->{isa}->isa('Moose::Meta::TypeConstraint') ) { + $options->{type_constraint} = $options->{isa}; + } + elsif ( + blessed( $options->{isa} ) + && $options->{isa}->can('does') + && $options->{isa}->does('Specio::Constraint::Role::Interface') + ) { + $options->{type_constraint} = $options->{isa}; + } + else { + $options->{type_constraint} + = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint( + $options->{isa}, + { package_defined_in => $options->{definition_context}->{package} } + ); + } +} + +sub _process_does_option { + my ( $class, $name, $options ) = @_; + + return unless exists $options->{does} && ! exists $options->{isa}; + + # allow for anon-subtypes here ... + if ( blessed( $options->{does} ) + && $options->{does}->isa('Moose::Meta::TypeConstraint') ) { + $options->{type_constraint} = $options->{does}; + } + else { + $options->{type_constraint} + = Moose::Util::TypeConstraints::find_or_create_does_type_constraint( + $options->{does}, + { package_defined_in => $options->{definition_context}->{package} } + ); + } +} + +sub _process_coerce_option { + my ( $class, $name, $options ) = @_; + + return unless $options->{coerce}; + + ( exists $options->{type_constraint} ) + || throw_exception( CoercionNeedsTypeConstraint => attribute_name => $name, + params => $options, + ); + + throw_exception( CannotCoerceAWeakRef => attribute_name => $name, + params => $options, + ) + if $options->{weak_ref}; + + unless ( $options->{type_constraint}->has_coercion ) { + my $type = $options->{type_constraint}->name; + + throw_exception( CannotCoerceAttributeWhichHasNoCoercion => attribute_name => $name, + type_name => $type, + params => $options + ); + } +} + +sub _process_trigger_option { + my ( $class, $name, $options ) = @_; + + return unless exists $options->{trigger}; + + ( 'CODE' eq ref $options->{trigger} ) + || throw_exception( TriggerMustBeACodeRef => attribute_name => $name, + params => $options, + ); +} + +sub _process_auto_deref_option { + my ( $class, $name, $options ) = @_; + + return unless $options->{auto_deref}; + + ( exists $options->{type_constraint} ) + || throw_exception( CannotAutoDerefWithoutIsa => attribute_name => $name, + params => $options, + ); + + ( $options->{type_constraint}->is_a_type_of('ArrayRef') + || $options->{type_constraint}->is_a_type_of('HashRef') ) + || throw_exception( AutoDeRefNeedsArrayRefOrHashRef => attribute_name => $name, + params => $options, + ); +} + +sub _process_lazy_build_option { + my ( $class, $name, $options ) = @_; + + return unless $options->{lazy_build}; + + throw_exception( CannotUseLazyBuildAndDefaultSimultaneously => attribute_name => $name, + params => $options, + ) + if exists $options->{default}; + + $options->{lazy} = 1; + $options->{builder} ||= "_build_${name}"; + + if ( $name =~ /^_/ ) { + $options->{clearer} ||= "_clear${name}"; + $options->{predicate} ||= "_has${name}"; + } + else { + $options->{clearer} ||= "clear_${name}"; + $options->{predicate} ||= "has_${name}"; + } +} + +sub _process_lazy_option { + my ( $class, $name, $options ) = @_; + + return unless $options->{lazy}; + + ( exists $options->{default} || defined $options->{builder} ) + || throw_exception( LazyAttributeNeedsADefault => params => $options, + attribute_name => $name, + ); +} + +sub _process_required_option { + my ( $class, $name, $options ) = @_; + + if ( + $options->{required} + && !( + ( !exists $options->{init_arg} || defined $options->{init_arg} ) + || exists $options->{default} + || defined $options->{builder} + ) + ) { + throw_exception( RequiredAttributeNeedsADefault => params => $options, + attribute_name => $name, + ); + } +} + +sub initialize_instance_slot { + my ($self, $meta_instance, $instance, $params) = @_; + my $init_arg = $self->init_arg(); + # try to fetch the init arg from the %params ... + + my $val; + my $value_is_set; + if ( defined($init_arg) and exists $params->{$init_arg}) { + $val = $params->{$init_arg}; + $value_is_set = 1; + } + else { + # skip it if it's lazy + return if $self->is_lazy; + # and die if it's required and doesn't have a default value + my $class_name = blessed( $instance ); + throw_exception(AttributeIsRequired => attribute_name => $self->name, + class_name => $class_name, + params => $params, + ) + if $self->is_required && !$self->has_default && !$self->has_builder; + + # if nothing was in the %params, we can use the + # attribute's default value (if it has one) + if ($self->has_default) { + $val = $self->default($instance); + $value_is_set = 1; + } + elsif ($self->has_builder) { + $val = $self->_call_builder($instance); + $value_is_set = 1; + } + } + + return unless $value_is_set; + + $val = $self->_coerce_and_verify( $val, $instance ); + + $self->set_initial_value($instance, $val); + + if ( ref $val && $self->is_weak_ref ) { + $self->_weaken_value($instance); + } +} + +sub _call_builder { + my ( $self, $instance ) = @_; + + my $builder = $self->builder(); + + return $instance->$builder() + if $instance->can( $self->builder ); + + throw_exception( BuilderDoesNotExist => instance => $instance, + attribute => $self, + ); +} + +## Slot management + +sub _make_initializer_writer_callback { + my $self = shift; + my ($meta_instance, $instance, $slot_name) = @_; + my $old_callback = $self->SUPER::_make_initializer_writer_callback(@_); + return sub { + $old_callback->($self->_coerce_and_verify($_[0], $instance)); + }; +} + +sub set_value { + my ($self, $instance, @args) = @_; + my $value = $args[0]; + + my $attr_name = quotemeta($self->name); + + my $class_name = blessed( $instance ); + if ($self->is_required and not @args) { + throw_exception( AttributeIsRequired => attribute_name => $self->name, + class_name => $class_name, + ); + } + + $value = $self->_coerce_and_verify( $value, $instance ); + + my @old; + if ( $self->has_trigger && $self->has_value($instance) ) { + @old = $self->get_value($instance, 'for trigger'); + } + + $self->SUPER::set_value($instance, $value); + + if ( ref $value && $self->is_weak_ref ) { + $self->_weaken_value($instance); + } + + if ($self->has_trigger) { + $self->trigger->($instance, $value, @old); + } +} + +sub _inline_set_value { + my $self = shift; + my ($instance, $value, $tc, $coercion, $message, $for_constructor) = @_; + + my $old = '@old'; + my $copy = '$val'; + $tc ||= '$type_constraint'; + $coercion ||= '$type_coercion'; + $message ||= '$type_message'; + + my @code; + if ($self->_writer_value_needs_copy) { + push @code, $self->_inline_copy_value($value, $copy); + $value = $copy; + } + + # constructors already handle required checks + push @code, $self->_inline_check_required + unless $for_constructor; + + push @code, $self->_inline_tc_code($value, $tc, $coercion, $message); + + # constructors do triggers all at once at the end + push @code, $self->_inline_get_old_value_for_trigger($instance, $old) + unless $for_constructor; + + push @code, ( + $self->SUPER::_inline_set_value($instance, $value), + $self->_inline_weaken_value($instance, $value), + ); + + # constructors do triggers all at once at the end + push @code, $self->_inline_trigger($instance, $value, $old) + unless $for_constructor; + + return @code; +} + +sub _writer_value_needs_copy { + my $self = shift; + return $self->should_coerce; +} + +sub _inline_copy_value { + my $self = shift; + my ($value, $copy) = @_; + + return 'my ' . $copy . ' = ' . $value . ';' +} + +sub _inline_check_required { + my $self = shift; + + return unless $self->is_required; + + my $attr_name = quotemeta($self->name); + + return ( + 'if (@_ < 2) {', + $self->_inline_throw_exception( AttributeIsRequired => + 'attribute_name => "'.$attr_name.'",'. + 'class_name => $class_name' + ) . ';', + '}', + ); +} + +sub _inline_tc_code { + my $self = shift; + my ($value, $tc, $coercion, $message, $is_lazy) = @_; + return ( + $self->_inline_check_coercion( + $value, $tc, $coercion, $is_lazy, + ), + $self->_inline_check_constraint( + $value, $tc, $message, $is_lazy, + ), + ); +} + +sub _inline_check_coercion { + my $self = shift; + my ($value, $tc, $coercion) = @_; + + return unless $self->should_coerce && $self->type_constraint->has_coercion; + + if ( $self->type_constraint->can_be_inlined ) { + return ( + 'if (! (' . $self->type_constraint->_inline_check($value) . ')) {', + $value . ' = ' . $coercion . '->(' . $value . ');', + '}', + ); + } + else { + return ( + 'if (!' . $tc . '->(' . $value . ')) {', + $value . ' = ' . $coercion . '->(' . $value . ');', + '}', + ); + } +} + +sub _inline_check_constraint { + my $self = shift; + my ($value, $tc, $message) = @_; + + return unless $self->has_type_constraint; + + my $attr_name = quotemeta($self->name); + + if ( $self->type_constraint->can_be_inlined ) { + return ( + 'if (! (' . $self->type_constraint->_inline_check($value) . ')) {', + 'my $msg = do { local $_ = ' . $value . '; ' + . $message . '->(' . $value . ');' + . '};'. + $self->_inline_throw_exception( ValidationFailedForInlineTypeConstraint => + 'type_constraint_message => $msg , '. + 'class_name => $class_name, '. + 'attribute_name => "'.$attr_name.'",'. + 'value => '.$value + ).';', + '}', + ); + } + else { + return ( + 'if (!' . $tc . '->(' . $value . ')) {', + 'my $msg = do { local $_ = ' . $value . '; ' + . $message . '->(' . $value . ');' + . '};'. + $self->_inline_throw_exception( ValidationFailedForInlineTypeConstraint => + 'type_constraint_message => $msg , '. + 'class_name => $class_name, '. + 'attribute_name => "'.$attr_name.'",'. + 'value => '.$value + ).';', + '}', + ); + } +} + +sub _inline_get_old_value_for_trigger { + my $self = shift; + my ($instance, $old) = @_; + + return unless $self->has_trigger; + + return ( + 'my ' . $old . ' = ' . $self->_inline_instance_has($instance), + '? ' . $self->_inline_instance_get($instance), + ': ();', + ); +} + +sub _inline_weaken_value { + my $self = shift; + my ($instance, $value) = @_; + + return unless $self->is_weak_ref; + + my $mi = $self->associated_class->get_meta_instance; + return ( + $mi->inline_weaken_slot_value($instance, $self->name), + 'if ref ' . $value . ';', + ); +} + +sub _inline_trigger { + my $self = shift; + my ($instance, $value, $old) = @_; + + return unless $self->has_trigger; + + return '$trigger->(' . $instance . ', ' . $value . ', ' . $old . ');'; +} + +sub _eval_environment { + my $self = shift; + + my $env = { }; + + $env->{'$trigger'} = \($self->trigger) + if $self->has_trigger; + $env->{'$attr_default'} = \($self->default) + if $self->has_default; + + if ($self->has_type_constraint) { + my $tc_obj = $self->type_constraint; + + $env->{'$type_constraint'} = \( + $tc_obj->_compiled_type_constraint + ) unless $tc_obj->can_be_inlined; + # these two could probably get inlined versions too + $env->{'$type_coercion'} = \( + $tc_obj->coercion->_compiled_type_coercion + ) if $tc_obj->has_coercion; + $env->{'$type_message'} = \( + $tc_obj->has_message ? $tc_obj->message : $tc_obj->_default_message + ); + + $env = { %$env, %{ $tc_obj->inline_environment } }; + } + + $env->{'$class_name'} = \($self->associated_class->name); + + # XXX ugh, fix these + $env->{'$attr'} = \$self + if $self->has_initializer && $self->is_lazy; + # pretty sure this is only going to be closed over if you use a custom + # error class at this point, but we should still get rid of this + # at some point + $env->{'$meta'} = \($self->associated_class); + + return $env; +} + +sub _weaken_value { + my ( $self, $instance ) = @_; + + my $meta_instance = Class::MOP::Class->initialize( blessed($instance) ) + ->get_meta_instance; + + $meta_instance->weaken_slot_value( $instance, $self->name ); +} + +sub get_value { + my ($self, $instance, $for_trigger) = @_; + + if ($self->is_lazy) { + unless ($self->has_value($instance)) { + my $value; + if ($self->has_default) { + $value = $self->default($instance); + } elsif ( $self->has_builder ) { + $value = $self->_call_builder($instance); + } + + $value = $self->_coerce_and_verify( $value, $instance ); + + $self->set_initial_value($instance, $value); + + if ( ref $value && $self->is_weak_ref ) { + $self->_weaken_value($instance); + } + } + } + + if ( $self->should_auto_deref && ! $for_trigger ) { + + my $type_constraint = $self->type_constraint; + + if ($type_constraint->is_a_type_of('ArrayRef')) { + my $rv = $self->SUPER::get_value($instance); + return unless defined $rv; + return wantarray ? @{ $rv } : $rv; + } + elsif ($type_constraint->is_a_type_of('HashRef')) { + my $rv = $self->SUPER::get_value($instance); + return unless defined $rv; + return wantarray ? %{ $rv } : $rv; + } + else { + throw_exception( CannotAutoDereferenceTypeConstraint => type_name => $type_constraint->name, + instance => $instance, + attribute => $self + ); + } + + } + else { + + return $self->SUPER::get_value($instance); + } +} + +sub _inline_get_value { + my $self = shift; + my ($instance, $tc, $coercion, $message) = @_; + + my $slot_access = $self->_inline_instance_get($instance); + $tc ||= '$type_constraint'; + $coercion ||= '$type_coercion'; + $message ||= '$type_message'; + + return ( + $self->_inline_check_lazy($instance, $tc, $coercion, $message), + $self->_inline_return_auto_deref($slot_access), + ); +} + +sub _inline_check_lazy { + my $self = shift; + my ($instance, $tc, $coercion, $message) = @_; + + return unless $self->is_lazy; + + my $slot_exists = $self->_inline_instance_has($instance); + + return ( + 'if (!' . $slot_exists . ') {', + $self->_inline_init_from_default($instance, '$default', $tc, $coercion, $message, 'lazy'), + '}', + ); +} + +sub _inline_init_from_default { + my $self = shift; + my ($instance, $default, $tc, $coercion, $message, $for_lazy) = @_; + + if (!($self->has_default || $self->has_builder)) { + throw_exception( LazyAttributeNeedsADefault => attribute => $self ); + } + + return ( + $self->_inline_generate_default($instance, $default), + # intentionally not using _inline_tc_code, since that can be overridden + # to do things like possibly only do member tc checks, which isn't + # appropriate for checking the result of a default + $self->has_type_constraint + ? ($self->_inline_check_coercion($default, $tc, $coercion, $for_lazy), + $self->_inline_check_constraint($default, $tc, $message, $for_lazy)) + : (), + $self->_inline_init_slot($instance, $default), + $self->_inline_weaken_value($instance, $default), + ); +} + +sub _inline_generate_default { + my $self = shift; + my ($instance, $default) = @_; + + if ($self->has_default) { + my $source = 'my ' . $default . ' = $attr_default'; + $source .= '->(' . $instance . ')' + if $self->is_default_a_coderef; + return $source . ';'; + } + elsif ($self->has_builder) { + my $builder = B::perlstring($self->builder); + my $builder_str = quotemeta($self->builder); + my $attr_name_str = quotemeta($self->name); + return ( + 'my ' . $default . ';', + 'if (my $builder = ' . $instance . '->can(' . $builder . ')) {', + $default . ' = ' . $instance . '->$builder;', + '}', + 'else {', + 'my $class = ref(' . $instance . ') || ' . $instance . ';', + $self->_inline_throw_exception( + BuilderMethodNotSupportedForInlineAttribute => + 'class_name => $class,'. + 'attribute_name => "'.$attr_name_str.'",'. + 'instance => '.$instance.','. + 'builder => "'.$builder_str.'"' + ) . ';', + '}', + ); + } + else { + confess( + "Can't generate a default for " . $self->name + . " since no default or builder was specified" + ); + } +} + +sub _inline_init_slot { + my $self = shift; + my ($inv, $value) = @_; + + if ($self->has_initializer) { + return '$attr->set_initial_value(' . $inv . ', ' . $value . ');'; + } + else { + return $self->_inline_instance_set($inv, $value) . ';'; + } +} + +sub _inline_return_auto_deref { + my $self = shift; + + return 'return ' . $self->_auto_deref(@_) . ';'; +} + +sub _auto_deref { + my $self = shift; + my ($ref_value) = @_; + + return $ref_value unless $self->should_auto_deref; + + my $type_constraint = $self->type_constraint; + + my $sigil; + if ($type_constraint->is_a_type_of('ArrayRef')) { + $sigil = '@'; + } + elsif ($type_constraint->is_a_type_of('HashRef')) { + $sigil = '%'; + } + else { + confess( + 'Can not auto de-reference the type constraint \'' + . $type_constraint->name + . '\'' + ); + } + + return 'wantarray ' + . '? ' . $sigil . '{ (' . $ref_value . ') || return } ' + . ': (' . $ref_value . ')'; +} + +## installing accessors + +sub accessor_metaclass { 'Moose::Meta::Method::Accessor' } + +sub install_accessors { + my $self = shift; + $self->SUPER::install_accessors(@_); + $self->install_delegation if $self->has_handles; + return; +} + +sub _check_associated_methods { + my $self = shift; + unless ( + @{ $self->associated_methods } + || ($self->_is_metadata || '') eq 'bare' + ) { + Carp::cluck( + 'Attribute (' . $self->name . ') of class ' + . $self->associated_class->name + . ' has no associated methods' + . ' (did you mean to provide an "is" argument?)' + . "\n" + ) + } +} + +sub _process_accessors { + my $self = shift; + my ($type, $accessor, $generate_as_inline_methods) = @_; + + $accessor = ( keys %$accessor )[0] if ( ref($accessor) || '' ) eq 'HASH'; + my $method = $self->associated_class->get_method($accessor); + + if ( $method + && $method->isa('Class::MOP::Method::Accessor') + && $method->associated_attribute->name ne $self->name ) { + + my $other_attr_name = $method->associated_attribute->name; + my $name = $self->name; + + Carp::cluck( + "You are overwriting an accessor ($accessor) for the $other_attr_name attribute" + . " with a new accessor method for the $name attribute" ); + } + + if ( + $method + && !$method->is_stub + && !$method->isa('Class::MOP::Method::Accessor') + && ( !$self->definition_context + || $method->package_name eq $self->definition_context->{package} ) + ) { + + Carp::cluck( + "You are overwriting a locally defined method ($accessor) with " + . "an accessor" ); + } + + if ( !$self->associated_class->has_method($accessor) + && $self->associated_class->has_package_symbol( '&' . $accessor ) ) { + + Carp::cluck( + "You are overwriting a locally defined function ($accessor) with " + . "an accessor" ); + } + + $self->SUPER::_process_accessors(@_); +} + +sub remove_accessors { + my $self = shift; + $self->SUPER::remove_accessors(@_); + $self->remove_delegation if $self->has_handles; + return; +} + +sub install_delegation { + my $self = shift; + + # NOTE: + # Here we canonicalize the 'handles' option + # this will sort out any details and always + # return an hash of methods which we want + # to delagate to, see that method for details + my %handles = $self->_canonicalize_handles; + + # install the delegation ... + my $associated_class = $self->associated_class; + my $class_name = $associated_class->name; + + foreach my $handle ( sort keys %handles ) { + my $method_to_call = $handles{$handle}; + my $name = "${class_name}::${handle}"; + + if ( my $method = $associated_class->get_method($handle) ) { + throw_exception( + CannotDelegateLocalMethodIsPresent => attribute => $self, + method => $method, + ) unless $method->is_stub; + } + + # NOTE: + # handles is not allowed to delegate + # any of these methods, as they will + # override the ones in your class, which + # is almost certainly not what you want. + + # FIXME warn when $handle was explicitly specified, but not if the source is a regex or something + #cluck("Not delegating method '$handle' because it is a core method") and + next + if $class_name->isa("Moose::Object") + and $handle =~ /^BUILD|DEMOLISH$/ || Moose::Object->can($handle); + + my $method = $self->_make_delegation_method($handle, $method_to_call); + + $self->associated_class->add_method($method->name, $method); + $self->associate_method($method); + } +} + +sub remove_delegation { + my $self = shift; + my %handles = $self->_canonicalize_handles; + my $associated_class = $self->associated_class; + foreach my $handle (keys %handles) { + next unless any { $handle eq $_ } + map { $_->name } + @{ $self->associated_methods }; + $self->associated_class->remove_method($handle); + } +} + +# private methods to help delegation ... + +sub _canonicalize_handles { + my $self = shift; + my $handles = $self->handles; + if (my $handle_type = ref($handles)) { + if ($handle_type eq 'HASH') { + return %{$handles}; + } + elsif ($handle_type eq 'ARRAY') { + return map { $_ => $_ } @{$handles}; + } + elsif ($handle_type eq 'Regexp') { + ($self->has_type_constraint) + || throw_exception( CannotDelegateWithoutIsa => attribute => $self ); + return map { ($_ => $_) } + grep { /$handles/ } $self->_get_delegate_method_list; + } + elsif ($handle_type eq 'CODE') { + return $handles->($self, $self->_find_delegate_metaclass); + } + elsif (blessed($handles) && $handles->isa('Moose::Meta::TypeConstraint::DuckType')) { + return map { $_ => $_ } @{ $handles->methods }; + } + elsif (blessed($handles) && $handles->isa('Moose::Meta::TypeConstraint::Role')) { + $handles = $handles->role; + } + else { + throw_exception( UnableToCanonicalizeHandles => attribute => $self, + handles => $handles + ); + } + } + + Moose::Util::_load_user_class($handles); + my $role_meta = Class::MOP::class_of($handles); + + (blessed $role_meta && $role_meta->isa('Moose::Meta::Role')) + || throw_exception( UnableToCanonicalizeNonRolePackage => attribute => $self, + handles => $handles + ); + + return map { $_ => $_ } + map { $_->name } + grep { !$_->isa('Class::MOP::Method::Meta') } ( + $role_meta->_get_local_methods, + $role_meta->get_required_method_list, + ); +} + +sub _get_delegate_method_list { + my $self = shift; + my $meta = $self->_find_delegate_metaclass; + if ($meta->isa('Class::MOP::Class')) { + return map { $_->name } # NOTE: !never! delegate &meta + grep { $_->package_name ne 'Moose::Object' && !$_->isa('Class::MOP::Method::Meta') } + $meta->get_all_methods; + } + elsif ($meta->isa('Moose::Meta::Role')) { + return $meta->get_method_list; + } + else { + throw_exception( UnableToRecognizeDelegateMetaclass => attribute => $self, + delegate_metaclass => $meta + ); + } +} + +sub _find_delegate_metaclass { + my $self = shift; + my $class = $self->_isa_metadata; + my $role = $self->_does_metadata; + + if ( $class ) { + # make sure isa is actually a class + unless ( $self->type_constraint->isa("Moose::Meta::TypeConstraint::Class") ) { + throw_exception( DelegationToATypeWhichIsNotAClass => attribute => $self ); + } + + # make sure the class is loaded + unless ( Moose::Util::_is_package_loaded($class) ) { + throw_exception( DelegationToAClassWhichIsNotLoaded => attribute => $self, + class_name => $class + ); + } + # we might be dealing with a non-Moose class, + # and need to make our own metaclass. if there's + # already a metaclass, it will be returned + return Class::MOP::Class->initialize($class); + } + elsif ( $role ) { + unless ( Moose::Util::_is_package_loaded($role) ) { + throw_exception( DelegationToARoleWhichIsNotLoaded => attribute => $self, + role_name => $role + ); + } + + return Class::MOP::class_of($role); + } + else { + throw_exception( CannotFindDelegateMetaclass => attribute => $self ); + } +} + +sub delegation_metaclass { 'Moose::Meta::Method::Delegation' } + +sub _make_delegation_method { + my ( $self, $handle_name, $method_to_call ) = @_; + + my @curried_arguments; + + ($method_to_call, @curried_arguments) = @$method_to_call + if 'ARRAY' eq ref($method_to_call); + + return $self->delegation_metaclass->new( + name => $handle_name, + package_name => $self->associated_class->name, + attribute => $self, + delegate_to_method => $method_to_call, + curried_arguments => \@curried_arguments, + ); +} + +sub _coerce_and_verify { + my $self = shift; + my $val = shift; + my $instance = shift; + + return $val unless $self->has_type_constraint; + + $val = $self->type_constraint->coerce($val) + if $self->should_coerce && $self->type_constraint->has_coercion; + + $self->verify_against_type_constraint($val, instance => $instance); + + return $val; +} + +sub verify_against_type_constraint { + my $self = shift; + my $val = shift; + + return 1 if !$self->has_type_constraint; + + my $type_constraint = $self->type_constraint; + + $type_constraint->check($val) + || throw_exception( ValidationFailedForTypeConstraint => type => $type_constraint, + value => $val, + attribute => $self, + ); +} + +package Moose::Meta::Attribute::Custom::Moose; +our $VERSION = '2.1403'; + +sub register_implementation { 'Moose::Meta::Attribute' } +1; + +# ABSTRACT: The Moose attribute metaclass + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Attribute - The Moose attribute metaclass + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class is a subclass of L<Class::MOP::Attribute> that provides +additional Moose-specific functionality. + +To really understand this class, you will need to start with the +L<Class::MOP::Attribute> 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<Moose::Meta::Attribute> is a subclass of L<Class::MOP::Attribute>. + +=head1 METHODS + +Many of the documented below override methods in +L<Class::MOP::Attribute> and add Moose specific features. + +=head2 Creation + +=over 4 + +=item B<< Moose::Meta::Attribute->new($name, %options) >> + +This method overrides the L<Class::MOP::Attribute> constructor. + +Many of the options below are described in more detail in the +L<Moose::Manual::Attributes> document. + +It adds the following options to the constructor: + +=over 8 + +=item * is => 'ro', 'rw', 'bare' + +This provides a shorthand for specifying the C<reader>, C<writer>, or +C<accessor> names. If the attribute is read-only ('ro') then it will +have a C<reader> method with the same attribute as the name. + +If it is read-write ('rw') then it will have an C<accessor> method +with the same name. If you provide an explicit C<writer> for a +read-write attribute, then you will have a C<reader> with the same +name as the attribute, and a C<writer> with the name you provided. + +Use 'bare' when you are deliberately not installing any methods +(accessor, reader, etc.) associated with this attribute; otherwise, +Moose will issue a warning when this attribute is added to a +metaclass. + +=item * isa => $type + +This option accepts a type. The type can be a string, which should be +a type name. If the type name is unknown, it is assumed to be a class +name. + +This option can also accept a L<Moose::Meta::TypeConstraint> object. + +If you I<also> provide a C<does> option, then your C<isa> option must +be a class name, and that class must do the role specified with +C<does>. + +=item * does => $role + +This is short-hand for saying that the attribute's type must be an +object which does the named role. + +=item * coerce => $bool + +This option is only valid for objects with a type constraint +(C<isa>) that defined a coercion. If this is true, then coercions will be applied whenever +this attribute is set. + +You cannot make both this and the C<weak_ref> option true. + +=item * trigger => $sub + +This option accepts a subroutine reference, which will be called after +the attribute is set. + +=item * required => $bool + +An attribute which is required must be provided to the constructor. An +attribute which is required can also have a C<default> or C<builder>, +which will satisfy its required-ness. + +A required attribute must have a C<default>, C<builder> or a +non-C<undef> C<init_arg> + +=item * lazy => $bool + +A lazy attribute must have a C<default> or C<builder>. When an +attribute is lazy, the default value will not be calculated until the +attribute is read. + +=item * weak_ref => $bool + +If this is true, the attribute's value will be stored as a weak +reference. + +=item * documentation + +An arbitrary string that can be retrieved later by calling C<< +$attr->documentation >>. + +=item * auto_deref => $bool + +B<Note that in cases where you want this feature you are often better served +by using a L<Moose::Meta::Attribute::Native> trait instead>. + +If this is true, then the reader will dereference the value when it is +called. The attribute must have a type constraint which defines the +attribute as an array or hash reference. + +=item * lazy_build => $bool + +B<Note that use of this feature is strongly discouraged.> Some documentation +used to encourage use of this feature as a best practice, but we have changed +our minds. + +Setting this to true makes the attribute lazy and provides a number of +default methods. + + has 'size' => ( + is => 'ro', + lazy_build => 1, + ); + +is equivalent to this: + + has 'size' => ( + is => 'ro', + lazy => 1, + builder => '_build_size', + clearer => 'clear_size', + predicate => 'has_size', + ); + +If your attribute name starts with an underscore (C<_>), then the clearer +and predicate will as well: + + has '_size' => ( + is => 'ro', + lazy_build => 1, + ); + +becomes: + + has '_size' => ( + is => 'ro', + lazy => 1, + builder => '_build__size', + clearer => '_clear_size', + predicate => '_has_size', + ); + +Note the doubled underscore in the builder name. Internally, Moose +simply prepends the attribute name with "_build_" to come up with the +builder name. + +=back + +=item B<< $attr->clone(%options) >> + +This creates a new attribute based on attribute being cloned. You must +supply a C<name> option to provide a new name for the attribute. + +The C<%options> can only specify options handled by +L<Class::MOP::Attribute>. + +=back + +=head2 Value management + +=over 4 + +=item B<< $attr->initialize_instance_slot($meta_instance, $instance, $params) >> + +This method is used internally to initialize the attribute's slot in +the object C<$instance>. + +This overrides the L<Class::MOP::Attribute> method to handle lazy +attributes, weak references, and type constraints. + +=item B<get_value> + +=item B<set_value> + + eval { $point->meta->get_attribute('x')->set_value($point, 'forty-two') }; + if($@) { + print "Oops: $@\n"; + } + +I<Attribute (x) does not pass the type constraint (Int) with 'forty-two'> + +Before setting the value, a check is made on the type constraint of +the attribute, if it has one, to see if the value passes it. If the +value fails to pass, the set operation dies. + +Any coercion to convert values is done before checking the type constraint. + +To check a value against a type constraint before setting it, fetch the +attribute instance using L<Class::MOP::Class/find_attribute_by_name>, +fetch the type_constraint from the attribute using L<Moose::Meta::Attribute/type_constraint> +and call L<Moose::Meta::TypeConstraint/check>. See L<Moose::Cookbook::Basics::Company_Subtypes> +for an example. + +=back + +=head2 Attribute Accessor generation + +=over 4 + +=item B<< $attr->install_accessors >> + +This method overrides the parent to also install delegation methods. + +If, after installing all methods, the attribute object has no associated +methods, it throws an error unless C<< is => 'bare' >> was passed to the +attribute constructor. (Trying to add an attribute that has no associated +methods is almost always an error.) + +=item B<< $attr->remove_accessors >> + +This method overrides the parent to also remove delegation methods. + +=item B<< $attr->inline_set($instance_var, $value_var) >> + +This method return a code snippet suitable for inlining the relevant +operation. It expect strings containing variable names to be used in the +inlining, like C<'$self'> or C<'$_[1]'>. + +=item B<< $attr->install_delegation >> + +This method adds its delegation methods to the attribute's associated +class, if it has any to add. + +=item B<< $attr->remove_delegation >> + +This method remove its delegation methods from the attribute's +associated class. + +=item B<< $attr->accessor_metaclass >> + +Returns the accessor metaclass name, which defaults to +L<Moose::Meta::Method::Accessor>. + +=item B<< $attr->delegation_metaclass >> + +Returns the delegation metaclass name, which defaults to +L<Moose::Meta::Method::Delegation>. + +=back + +=head2 Additional Moose features + +These methods are not found in the superclass. They support features +provided by Moose. + +=over 4 + +=item B<< $attr->does($role) >> + +This indicates whether the I<attribute itself> does the given +role. The role can be given as a full class name, or as a resolvable +trait name. + +Note that this checks the attribute itself, not its type constraint, +so it is checking the attribute's metaclass and any traits applied to +the attribute. + +=item B<< Moose::Meta::Class->interpolate_class_and_new($name, %options) >> + +This is an alternate constructor that handles the C<metaclass> and +C<traits> options. + +Effectively, this method is a factory that finds or creates the +appropriate class for the given C<metaclass> and/or C<traits>. + +Once it has the appropriate class, it will call C<< $class->new($name, +%options) >> on that class. + +=item B<< $attr->clone_and_inherit_options(%options) >> + +This method supports the C<has '+foo'> feature. It does various bits +of processing on the supplied C<%options> before ultimately calling +the C<clone> method. + +One of its main tasks is to make sure that the C<%options> provided +does not include the options returned by the +C<illegal_options_for_inheritance> method. + +=item B<< $attr->illegal_options_for_inheritance >> + +This returns a blacklist of options that can not be overridden in a +subclass's attribute definition. + +This exists to allow a custom metaclass to change or add to the list +of options which can not be changed. + +=item B<< $attr->type_constraint >> + +Returns the L<Moose::Meta::TypeConstraint> object for this attribute, +if it has one. + +=item B<< $attr->has_type_constraint >> + +Returns true if this attribute has a type constraint. + +=item B<< $attr->verify_against_type_constraint($value) >> + +Given a value, this method returns true if the value is valid for the +attribute's type constraint. If the value is not valid, it throws an +error. + +=item B<< $attr->handles >> + +This returns the value of the C<handles> option passed to the +constructor. + +=item B<< $attr->has_handles >> + +Returns true if this attribute performs delegation. + +=item B<< $attr->is_weak_ref >> + +Returns true if this attribute stores its value as a weak reference. + +=item B<< $attr->is_required >> + +Returns true if this attribute is required to have a value. + +=item B<< $attr->is_lazy >> + +Returns true if this attribute is lazy. + +=item B<< $attr->is_lazy_build >> + +Returns true if the C<lazy_build> option was true when passed to the +constructor. + +=item B<< $attr->should_coerce >> + +Returns true if the C<coerce> option passed to the constructor was +true. + +=item B<< $attr->should_auto_deref >> + +Returns true if the C<auto_deref> option passed to the constructor was +true. + +=item B<< $attr->trigger >> + +This is the subroutine reference that was in the C<trigger> option +passed to the constructor, if any. + +=item B<< $attr->has_trigger >> + +Returns true if this attribute has a trigger set. + +=item B<< $attr->documentation >> + +Returns the value that was in the C<documentation> option passed to +the constructor, if any. + +=item B<< $attr->has_documentation >> + +Returns true if this attribute has any documentation. + +=item B<< $attr->applied_traits >> + +This returns an array reference of all the traits which were applied +to this attribute. If none were applied, this returns C<undef>. + +=item B<< $attr->has_applied_traits >> + +Returns true if this attribute has any traits applied. + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Attribute/Native.pm b/lib/Moose/Meta/Attribute/Native.pm new file mode 100644 index 0000000..8307129 --- /dev/null +++ b/lib/Moose/Meta/Attribute/Native.pm @@ -0,0 +1,299 @@ +use strict; +use warnings; +package Moose::Meta::Attribute::Native; +our $VERSION = '2.1405'; + +use Module::Runtime 'require_module'; + +my @trait_names = qw(Bool Counter Number String Array Hash Code); + +for my $trait_name (@trait_names) { + my $trait_class = "Moose::Meta::Attribute::Native::Trait::$trait_name"; + my $meta = Class::MOP::Class->initialize( + "Moose::Meta::Attribute::Custom::Trait::$trait_name" + ); + + if ($meta->find_method_by_name('register_implementation')) { + my $class = $meta->name->register_implementation; + die "An implementation for $trait_name already exists " . + "(found '$class' when trying to register '$trait_class')" + } + $meta->add_method(register_implementation => sub { + # resolve_metatrait_alias will load classes anyway, but throws away + # their error message; we WANT to die if there's a problem + require_module($trait_class); + return $trait_class; + }); +} + +1; + +# ABSTRACT: Delegate to native Perl types + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Attribute::Native - Delegate to native Perl types + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + package MyClass; + use Moose; + + has 'mapping' => ( + traits => ['Hash'], + is => 'rw', + isa => 'HashRef[Str]', + default => sub { {} }, + handles => { + exists_in_mapping => 'exists', + ids_in_mapping => 'keys', + get_mapping => 'get', + set_mapping => 'set', + set_quantity => [ set => 'quantity' ], + }, + ); + + my $obj = MyClass->new; + $obj->set_quantity(10); # quantity => 10 + $obj->set_mapping('foo', 4); # foo => 4 + $obj->set_mapping('bar', 5); # bar => 5 + $obj->set_mapping('baz', 6); # baz => 6 + + # prints 5 + print $obj->get_mapping('bar') if $obj->exists_in_mapping('bar'); + + # prints 'quantity, foo, bar, baz' + print join ', ', $obj->ids_in_mapping; + +=head1 DESCRIPTION + +Native delegations allow you to delegate to native Perl data +structures as if they were objects. For example, in the L</SYNOPSIS> you can +see a hash reference being treated as if it has methods named C<exists()>, +C<keys()>, C<get()>, and C<set()>. + +The delegation methods (mostly) map to Perl builtins and operators. The return +values of these delegations should be the same as the corresponding Perl +operation. Any deviations will be explicitly documented. + +=head1 API + +Native delegations are enabled by passing certain options to C<has> when +creating an attribute. + +=head2 traits + +To enable this feature, pass the appropriate name in the C<traits> array +reference for the attribute. For example, to enable this feature for hash +reference, we include C<'Hash'> in the list of traits. + +=head2 isa + +You will need to make sure that the attribute has an appropriate type. For +example, to use this with a Hash you must specify that your attribute is some +sort of C<HashRef>. + +=head2 handles + +This is just like any other delegation, but only a hash reference is allowed +when defining native delegations. The keys are the methods to be created in +the class which contains the attribute. The values are the methods provided by +the associated trait. Currying works the same way as it does with any other +delegation. + +See the docs for each native trait for details on what methods are available. + +=head1 TRAITS FOR NATIVE DELEGATIONS + +Below are some simple examples of each native trait. More features are +available than what is shown here; this is just a quick synopsis. + +=over + +=item Array (L<Moose::Meta::Attribute::Native::Trait::Array>) + + has 'queue' => ( + traits => ['Array'], + is => 'ro', + isa => 'ArrayRef[Str]', + default => sub { [] }, + handles => { + add_item => 'push', + next_item => 'shift', + # ... + } + ); + +=item Bool (L<Moose::Meta::Attribute::Native::Trait::Bool>) + + has 'is_lit' => ( + traits => ['Bool'], + is => 'ro', + isa => 'Bool', + default => 0, + handles => { + illuminate => 'set', + darken => 'unset', + flip_switch => 'toggle', + is_dark => 'not', + # ... + } + ); + +=item Code (L<Moose::Meta::Attribute::Native::Trait::Code>) + + has 'callback' => ( + traits => ['Code'], + is => 'ro', + isa => 'CodeRef', + default => sub { + sub {'called'} + }, + handles => { + call => 'execute', + # ... + } + ); + +=item Counter (L<Moose::Meta::Attribute::Native::Trait::Counter>) + + has 'counter' => ( + traits => ['Counter'], + is => 'ro', + isa => 'Num', + default => 0, + handles => { + inc_counter => 'inc', + dec_counter => 'dec', + reset_counter => 'reset', + # ... + } + ); + +=item Hash (L<Moose::Meta::Attribute::Native::Trait::Hash>) + + has 'options' => ( + traits => ['Hash'], + is => 'ro', + isa => 'HashRef[Str]', + default => sub { {} }, + handles => { + set_option => 'set', + get_option => 'get', + has_option => 'exists', + # ... + } + ); + +=item Number (L<Moose::Meta::Attribute::Native::Trait::Number>) + + has 'integer' => ( + traits => ['Number'], + is => 'ro', + isa => 'Int', + default => 5, + handles => { + set => 'set', + add => 'add', + sub => 'sub', + mul => 'mul', + div => 'div', + mod => 'mod', + abs => 'abs', + # ... + } + ); + +=item String (L<Moose::Meta::Attribute::Native::Trait::String>) + + has 'text' => ( + traits => ['String'], + is => 'ro', + isa => 'Str', + default => q{}, + handles => { + add_text => 'append', + replace_text => 'replace', + # ... + } + ); + +=back + +=head1 COMPATIBILITY WITH MooseX::AttributeHelpers + +This feature used to be a separated CPAN distribution called +L<MooseX::AttributeHelpers>. + +When the feature was incorporated into the Moose core, some of the API details +were changed. The underlying capabilities are the same, but some details of +the API were changed. + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Attribute/Native/Trait.pm b/lib/Moose/Meta/Attribute/Native/Trait.pm new file mode 100644 index 0000000..d61ce06 --- /dev/null +++ b/lib/Moose/Meta/Attribute/Native/Trait.pm @@ -0,0 +1,244 @@ +package Moose::Meta::Attribute::Native::Trait; +our $VERSION = '2.1405'; + +use Moose::Role; +use Module::Runtime 'require_module'; +use Moose::Deprecated; +use Moose::Util 'throw_exception'; +use Moose::Util::TypeConstraints; + +requires '_helper_type'; + +before '_process_options' => sub { + my ( $self, $name, $options ) = @_; + + $self->_check_helper_type( $options, $name ); +}; + +sub _check_helper_type { + my ( $self, $options, $name ) = @_; + + my $type = $self->_helper_type; + + $options->{isa} = $type + unless exists $options->{isa}; + + my $isa; + my $isa_name; + + if ( blessed( $options->{isa} ) + && $options->{isa}->can('does') + && $options->{isa}->does('Specio::Constraint::Role::Interface') ) { + + $isa = $options->{isa}; + require Specio::Library::Builtins; + return if $isa->is_a_type_of( Specio::Library::Builtins::t($type) ); + $isa_name = $isa->name() || $isa->description(); + } + else { + $isa = Moose::Util::TypeConstraints::find_or_create_type_constraint( + $options->{isa} ); + return if $isa->is_a_type_of($type); + $isa_name = $isa->name(); + } + + throw_exception( WrongTypeConstraintGiven => required_type => $type, + given_type => $isa_name, + attribute_name => $name, + params => $options + ); +} + +before 'install_accessors' => sub { (shift)->_check_handles_values }; + +sub _check_handles_values { + my $self = shift; + + my %handles = $self->_canonicalize_handles; + + for my $original_method ( values %handles ) { + my $name = $original_method->[0]; + + my $accessor_class = $self->_native_accessor_class_for($name); + + ( $accessor_class && $accessor_class->can('new') ) + || confess + "$name is an unsupported method type - $accessor_class"; + } +} + +around '_canonicalize_handles' => sub { + shift; + my $self = shift; + my $handles = $self->handles; + + return unless $handles; + + unless ( 'HASH' eq ref $handles ) { + throw_exception( HandlesMustBeAHashRef => instance => $self, + given_handles => $handles + ); + } + + return + map { $_ => $self->_canonicalize_handles_value( $handles->{$_} ) } + keys %$handles; +}; + +sub _canonicalize_handles_value { + my $self = shift; + my $value = shift; + + if ( ref $value && 'ARRAY' ne ref $value ) { + throw_exception( InvalidHandleValue => instance => $self, + handle_value => $value + ); + } + + return ref $value ? $value : [$value]; +} + +around '_make_delegation_method' => sub { + my $next = shift; + my ( $self, $handle_name, $method_to_call ) = @_; + + my ( $name, @curried_args ) = @$method_to_call; + + my $accessor_class = $self->_native_accessor_class_for($name); + + die "Cannot find an accessor class for $name" + unless $accessor_class && $accessor_class->can('new'); + + return $accessor_class->new( + name => $handle_name, + package_name => $self->associated_class->name, + delegate_to_method => $name, + attribute => $self, + is_inline => 1, + curried_arguments => \@curried_args, + root_types => [ $self->_root_types ], + ); +}; + +sub _root_types { + return $_[0]->_helper_type; +} + +sub _native_accessor_class_for { + my ( $self, $suffix ) = @_; + + my $role + = 'Moose::Meta::Method::Accessor::Native::' + . $self->_native_type . '::' + . $suffix; + + require_module($role); + return Moose::Meta::Class->create_anon_class( + superclasses => + [ $self->accessor_metaclass, $self->delegation_metaclass ], + roles => [$role], + cache => 1, + )->name; +} + +sub _build_native_type { + my $self = shift; + + for my $role_name ( map { $_->name } $self->meta->calculate_all_roles ) { + return $1 if $role_name =~ /::Native::Trait::(\w+)$/; + } + + throw_exception( CannotCalculateNativeType => instance => $self ); +} + +has '_native_type' => ( + is => 'ro', + isa => 'Str', + lazy => 1, + builder => '_build_native_type', +); + +no Moose::Role; +no Moose::Util::TypeConstraints; + +1; + +# ABSTRACT: Shared role for native delegation traits + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Attribute::Native::Trait - Shared role for native delegation traits + +=head1 VERSION + +version 2.1405 + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 SEE ALSO + +Documentation for Moose native traits can be found in +L<Moose::Meta::Attribute::Native>. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Attribute/Native/Trait/Array.pm b/lib/Moose/Meta/Attribute/Native/Trait/Array.pm new file mode 100644 index 0000000..3d33b08 --- /dev/null +++ b/lib/Moose/Meta/Attribute/Native/Trait/Array.pm @@ -0,0 +1,384 @@ +package Moose::Meta::Attribute::Native::Trait::Array; +our $VERSION = '2.1405'; + +use Moose::Role; +with 'Moose::Meta::Attribute::Native::Trait'; + +sub _helper_type { 'ArrayRef' } + +no Moose::Role; + +1; + +# ABSTRACT: Helper trait for ArrayRef attributes + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Attribute::Native::Trait::Array - Helper trait for ArrayRef attributes + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + package Stuff; + use Moose; + + has 'options' => ( + traits => ['Array'], + is => 'ro', + isa => 'ArrayRef[Str]', + default => sub { [] }, + handles => { + all_options => 'elements', + add_option => 'push', + map_options => 'map', + filter_options => 'grep', + find_option => 'first', + get_option => 'get', + join_options => 'join', + count_options => 'count', + has_options => 'count', + has_no_options => 'is_empty', + sorted_options => 'sort', + }, + ); + + no Moose; + 1; + +=head1 DESCRIPTION + +This trait provides native delegation methods for array references. + +=head1 DEFAULT TYPE + +If you don't provide an C<isa> value for your attribute, it will default to +C<ArrayRef>. + +=head1 PROVIDED METHODS + +=over 4 + +=item * B<count> + +Returns the number of elements in the array. + + $stuff = Stuff->new; + $stuff->options( [ "foo", "bar", "baz", "boo" ] ); + + print $stuff->count_options; # prints 4 + +This method does not accept any arguments. + +=item * B<is_empty> + +Returns a boolean value that is true when the array has no elements. + + $stuff->has_no_options ? die "No options!\n" : print "Good boy.\n"; + +This method does not accept any arguments. + +=item * B<elements> + +Returns all of the elements of the array as an array (not an array reference). + + my @option = $stuff->all_options; + print "@options\n"; # prints "foo bar baz boo" + +This method does not accept any arguments. + +=item * B<get($index)> + +Returns an element of the array by its index. You can also use negative index +numbers, just as with Perl's core array handling. + + my $option = $stuff->get_option(1); + print "$option\n"; # prints "bar" + +If the specified element does not exist, this will return C<undef>. + +This method accepts just one argument. + +=item * B<pop> + +Just like Perl's builtin C<pop>. + +This method does not accept any arguments. + +=item * B<push($value1, $value2, value3 ...)> + +Just like Perl's builtin C<push>. Returns the number of elements in the new +array. + +This method accepts any number of arguments. + +=item * B<shift> + +Just like Perl's builtin C<shift>. + +This method does not accept any arguments. + +=item * B<unshift($value1, $value2, value3 ...)> + +Just like Perl's builtin C<unshift>. Returns the number of elements in the new +array. + +This method accepts any number of arguments. + +=item * B<splice($offset, $length, @values)> + +Just like Perl's builtin C<splice>. In scalar context, this returns the last +element removed, or C<undef> if no elements were removed. In list context, +this returns all the elements removed from the array. + +This method requires at least one argument. + +=item * B<first( sub { ... } )> + +This method returns the first matching item in the array, just like +L<List::Util>'s C<first> function. The matching is done with a subroutine +reference you pass to this method. The subroutine will be called against each +element in the array until one matches or all elements have been checked. +Each list element will be available to the sub in C<$_>. + + my $found = $stuff->find_option( sub {/^b/} ); + print "$found\n"; # prints "bar" + +This method requires a single argument. + +=item * B<first_index( sub { ... } )> + +This method returns the index of the first matching item in the array, just +like L<List::MoreUtils>'s C<first_index> function. The matching is done with a +subroutine reference you pass to this method. The subroutine will be called +against each element in the array until one matches or all elements have been +checked. Each list element will be available to the sub in C<$_>. + +This method requires a single argument. + +=item * B<grep( sub { ... } )> + +This method returns every element matching a given criteria, just like Perl's +core C<grep> function. This method requires a subroutine which implements the +matching logic; each list element will be available to the sub in C<$_>. + + my @found = $stuff->filter_options( sub {/^b/} ); + print "@found\n"; # prints "bar baz boo" + +This method requires a single argument. + +=item * B<map( sub { ... } )> + +This method transforms every element in the array and returns a new array, +just like Perl's core C<map> function. This method requires a subroutine which +implements the transformation; each list element will be available to the sub +in C<$_>. + + my @mod_options = $stuff->map_options( sub { $_ . "-tag" } ); + print "@mod_options\n"; # prints "foo-tag bar-tag baz-tag boo-tag" + +This method requires a single argument. + +=item * B<reduce( sub { ... } )> + +This method turns an array into a single value, by passing a function the +value so far and the next value in the array, just like L<List::Util>'s +C<reduce> function. The reducing is done with a subroutine reference you pass +to this method; each list element will be available to the sub in C<$_>. + + my $found = $stuff->reduce_options( sub { $_[0] . $_[1] } ); + print "$found\n"; # prints "foobarbazboo" + +This method requires a single argument. + +=item * B<sort> + +=item * B<sort( sub { ... } )> + +Returns the elements of the array (not an array reference) in sorted order, +or, like C<elements>, returns the number of elements in the array in scalar context. + +You can provide an optional subroutine reference to sort with (as you can with +Perl's core C<sort> function). However, instead of using C<$a> and C<$b> in +this subroutine, you will need to use C<$_[0]> and C<$_[1]>. + + # ascending ASCIIbetical + my @sorted = $stuff->sort_options(); + + # Descending alphabetical order + my @sorted_options = $stuff->sort_options( sub { lc $_[1] cmp lc $_[0] } ); + print "@sorted_options\n"; # prints "foo boo baz bar" + +This method accepts a single argument. + +=item * B<sort_in_place> + +=item * B<sort_in_place( sub { ... } )> + +Sorts the array I<in place>, modifying the value of the attribute. + +You can provide an optional subroutine reference to sort with (as you can with +Perl's core C<sort> function). However, instead of using C<$a> and C<$b>, you +will need to use C<$_[0]> and C<$_[1]> instead. + +This method does not define a return value. + +This method accepts a single argument. + +=item * B<shuffle> + +Returns the elements of the array in random order, like C<shuffle> from +L<List::Util>. + +This method does not accept any arguments. + +=item * B<uniq> + +Returns the array with all duplicate elements removed, like C<uniq> from +L<List::MoreUtils>. + +This method does not accept any arguments. + +=item * B<join($str)> + +Joins every element of the array using the separator given as argument, just +like Perl's core C<join> function. + + my $joined = $stuff->join_options(':'); + print "$joined\n"; # prints "foo:bar:baz:boo" + +This method requires a single argument. + +=item * B<set($index, $value)> + +Given an index and a value, sets the specified array element's value. + +This method returns the value at C<$index> after the set. + +This method requires two arguments. + +=item * B<delete($index)> + +Removes the element at the given index from the array. + +This method returns the deleted value. Note that if no value exists, it will +return C<undef>. + +This method requires one argument. + +=item * B<insert($index, $value)> + +Inserts a new element into the array at the given index. + +This method returns the new value at C<$index>. + +This method requires two arguments. + +=item * B<clear> + +Empties the entire array, like C<@array = ()>. + +This method does not define a return value. + +This method does not accept any arguments. + +=item * B<accessor($index)> + +=item * B<accessor($index, $value)> + +This method provides a get/set accessor for the array, based on array indexes. +If passed one argument, it returns the value at the specified index. If +passed two arguments, it sets the value of the specified index. + +When called as a setter, this method returns the new value at C<$index>. + +This method accepts one or two arguments. + +=item * B<natatime($n)> + +=item * B<natatime($n, $code)> + +This method returns an iterator which, on each call, returns C<$n> more items +from the array, in order, like C<natatime> from L<List::MoreUtils>. + +If you pass a coderef as the second argument, then this code ref will be +called on each group of C<$n> elements in the array until the array is +exhausted. + +This method accepts one or two arguments. + +=item * B<shallow_clone> + +This method returns a shallow clone of the array reference. The return value +is a reference to a new array with the same elements. It is I<shallow> +because any elements that were references in the original will be the I<same> +references in the clone. + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Attribute/Native/Trait/Bool.pm b/lib/Moose/Meta/Attribute/Native/Trait/Bool.pm new file mode 100644 index 0000000..d228d0b --- /dev/null +++ b/lib/Moose/Meta/Attribute/Native/Trait/Bool.pm @@ -0,0 +1,146 @@ +package Moose::Meta::Attribute::Native::Trait::Bool; +our $VERSION = '2.1405'; + +use Moose::Role; +with 'Moose::Meta::Attribute::Native::Trait'; + +sub _helper_type { 'Bool' } + +no Moose::Role; + +1; + +# ABSTRACT: Helper trait for Bool attributes + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Attribute::Native::Trait::Bool - Helper trait for Bool attributes + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + package Room; + use Moose; + + has 'is_lit' => ( + traits => ['Bool'], + is => 'rw', + isa => 'Bool', + default => 0, + handles => { + illuminate => 'set', + darken => 'unset', + flip_switch => 'toggle', + is_dark => 'not', + }, + ); + + my $room = Room->new(); + $room->illuminate; # same as $room->is_lit(1); + $room->darken; # same as $room->is_lit(0); + $room->flip_switch; # same as $room->is_lit(not $room->is_lit); + return $room->is_dark; # same as !$room->is_lit + +=head1 DESCRIPTION + +This trait provides native delegation methods for boolean values. A boolean is +a scalar which can be C<1>, C<0>, C<"">, or C<undef>. + +=head1 DEFAULT TYPE + +If you don't provide an C<isa> value for your attribute, it will default to +C<Bool>. + +=head1 PROVIDED METHODS + +None of these methods accept arguments. + +=over 4 + +=item * B<set> + +Sets the value to C<1> and returns C<1>. + +=item * B<unset> + +Set the value to C<0> and returns C<0>. + +=item * B<toggle> + +Toggles the value. If it's true, set to false, and vice versa. + +Returns the new value. + +=item * B<not> + +Equivalent of 'not C<$value>'. + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Attribute/Native/Trait/Code.pm b/lib/Moose/Meta/Attribute/Native/Trait/Code.pm new file mode 100644 index 0000000..a0b90b3 --- /dev/null +++ b/lib/Moose/Meta/Attribute/Native/Trait/Code.pm @@ -0,0 +1,129 @@ +package Moose::Meta::Attribute::Native::Trait::Code; +our $VERSION = '2.1405'; + +use Moose::Role; +with 'Moose::Meta::Attribute::Native::Trait'; + +sub _helper_type { 'CodeRef' } + +no Moose::Role; + +1; + +# ABSTRACT: Helper trait for CodeRef attributes + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Attribute::Native::Trait::Code - Helper trait for CodeRef attributes + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + package Foo; + use Moose; + + has 'callback' => ( + traits => ['Code'], + is => 'ro', + isa => 'CodeRef', + default => sub { + sub { print "called" } + }, + handles => { + call => 'execute', + }, + ); + + my $foo = Foo->new; + $foo->call; # prints "called" + +=head1 DESCRIPTION + +This trait provides native delegation methods for code references. + +=head1 DEFAULT TYPE + +If you don't provide an C<isa> value for your attribute, it will default to +C<CodeRef>. + +=head1 PROVIDED METHODS + +=over 4 + +=item * B<execute(@args)> + +Calls the coderef with the given args. + +=item * B<execute_method(@args)> + +Calls the coderef with the instance as invocant and given args. + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Attribute/Native/Trait/Counter.pm b/lib/Moose/Meta/Attribute/Native/Trait/Counter.pm new file mode 100644 index 0000000..2677f88 --- /dev/null +++ b/lib/Moose/Meta/Attribute/Native/Trait/Counter.pm @@ -0,0 +1,157 @@ +package Moose::Meta::Attribute::Native::Trait::Counter; +our $VERSION = '2.1405'; + +use Moose::Role; +with 'Moose::Meta::Attribute::Native::Trait'; + +sub _helper_type { 'Num' } +sub _root_types { 'Num', 'Int' } + +no Moose::Role; + +1; + +# ABSTRACT: Helper trait for Int attributes which represent counters + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Attribute::Native::Trait::Counter - Helper trait for Int attributes which represent counters + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + package MyHomePage; + use Moose; + + has 'counter' => ( + traits => ['Counter'], + is => 'ro', + isa => 'Num', + default => 0, + handles => { + inc_counter => 'inc', + dec_counter => 'dec', + reset_counter => 'reset', + }, + ); + + my $page = MyHomePage->new(); + $page->inc_counter; # same as $page->counter( $page->counter + 1 ); + $page->dec_counter; # same as $page->counter( $page->counter - 1 ); + + my $count_by_twos = 2; + $page->inc_counter($count_by_twos); + +=head1 DESCRIPTION + +This trait provides native delegation methods for counters. A counter can be +any sort of number (integer or not). The delegation methods allow you to +increment, decrement, or reset the value. + +=head1 DEFAULT TYPE + +If you don't provide an C<isa> value for your attribute, it will default to +C<Num>. + +=head1 PROVIDED METHODS + +=over 4 + +=item * B<set($value)> + +Sets the counter to the specified value and returns the new value. + +This method requires a single argument. + +=item * B<inc> + +=item * B<inc($arg)> + +Increases the attribute value by the amount of the argument, or by 1 if no +argument is given. This method returns the new value. + +This method accepts a single argument. + +=item * B<dec> + +=item * B<dec($arg)> + +Decreases the attribute value by the amount of the argument, or by 1 if no +argument is given. This method returns the new value. + +This method accepts a single argument. + +=item * B<reset> + +Resets the value stored in this slot to its default value, and returns the new +value. + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Attribute/Native/Trait/Hash.pm b/lib/Moose/Meta/Attribute/Native/Trait/Hash.pm new file mode 100644 index 0000000..25fbc6b --- /dev/null +++ b/lib/Moose/Meta/Attribute/Native/Trait/Hash.pm @@ -0,0 +1,226 @@ +package Moose::Meta::Attribute::Native::Trait::Hash; +our $VERSION = '2.1405'; + +use Moose::Role; +with 'Moose::Meta::Attribute::Native::Trait'; + +sub _helper_type { 'HashRef' } + +no Moose::Role; + +1; + +# ABSTRACT: Helper trait for HashRef attributes + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Attribute::Native::Trait::Hash - Helper trait for HashRef attributes + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + package Stuff; + use Moose; + + has 'options' => ( + traits => ['Hash'], + is => 'ro', + isa => 'HashRef[Str]', + default => sub { {} }, + handles => { + set_option => 'set', + get_option => 'get', + has_no_options => 'is_empty', + num_options => 'count', + delete_option => 'delete', + option_pairs => 'kv', + }, + ); + +=head1 DESCRIPTION + +This trait provides native delegation methods for hash references. + +=head1 PROVIDED METHODS + +=over 4 + +=item B<get($key, $key2, $key3...)> + +Returns values from the hash. + +In list context it returns a list of values in the hash for the given keys. In +scalar context it returns the value for the last key specified. + +This method requires at least one argument. + +=item B<set($key =E<gt> $value, $key2 =E<gt> $value2...)> + +Sets the elements in the hash to the given values. It returns the new values +set for each key, in the same order as the keys passed to the method. + +This method requires at least two arguments, and expects an even number of +arguments. + +=item B<delete($key, $key2, $key3...)> + +Removes the elements with the given keys. + +In list context it returns a list of values in the hash for the deleted +keys. In scalar context it returns the value for the last key specified. + +=item B<keys> + +Returns the list of keys in the hash. + +This method does not accept any arguments. + +=item B<exists($key)> + +Returns true if the given key is present in the hash. + +This method requires a single argument. + +=item B<defined($key)> + +Returns true if the value of a given key is defined. + +This method requires a single argument. + +=item B<values> + +Returns the list of values in the hash. + +This method does not accept any arguments. + +=item B<kv> + +Returns the key/value pairs in the hash as an array of array references. + + for my $pair ( $object->option_pairs ) { + print "$pair->[0] = $pair->[1]\n"; + } + +This method does not accept any arguments. + +=item B<elements> + +Returns the key/value pairs in the hash as a flattened list.. + +This method does not accept any arguments. + +=item B<clear> + +Resets the hash to an empty value, like C<%hash = ()>. + +This method does not accept any arguments. + +=item B<count> + +Returns the number of elements in the hash. Also useful to check for a nonempty hash, because C<count> returns a true (nonzero) value if there is something in the hash: +C<< has_options => 'count' >>. + +This method does not accept any arguments. + +=item B<is_empty> + +If the hash is populated, returns false. Otherwise, returns true. + +This method does not accept any arguments. + +=item B<accessor($key)> + +=item B<accessor($key, $value)> + +If passed one argument, returns the value of the specified key. If passed two +arguments, sets the value of the specified key. + +When called as a setter, this method returns the value that was set. + +=item B<shallow_clone> + +This method returns a shallow clone of the hash reference. The return value +is a reference to a new hash with the same keys and values. It is I<shallow> +because any values that were references in the original will be the I<same> +references in the clone. + +=back + +Note that C<each> is deliberately omitted, due to its stateful interaction +with the hash iterator. C<keys> or C<kv> are much safer. + +=head1 METHODS + +=over 4 + +=item B<meta> + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Attribute/Native/Trait/Number.pm b/lib/Moose/Meta/Attribute/Native/Trait/Number.pm new file mode 100644 index 0000000..4851246 --- /dev/null +++ b/lib/Moose/Meta/Attribute/Native/Trait/Number.pm @@ -0,0 +1,155 @@ +package Moose::Meta::Attribute::Native::Trait::Number; +our $VERSION = '2.1405'; + +use Moose::Role; +with 'Moose::Meta::Attribute::Native::Trait'; + +sub _helper_type { 'Num' } + +no Moose::Role; + +1; + +# ABSTRACT: Helper trait for Num attributes + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Attribute::Native::Trait::Number - Helper trait for Num attributes + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + package Real; + use Moose; + + has 'integer' => ( + traits => ['Number'], + is => 'ro', + isa => 'Num', + default => 5, + handles => { + set => 'set', + add => 'add', + sub => 'sub', + mul => 'mul', + div => 'div', + mod => 'mod', + abs => 'abs', + }, + ); + + my $real = Real->new(); + $real->add(5); # same as $real->integer($real->integer + 5); + $real->sub(2); # same as $real->integer($real->integer - 2); + +=head1 DESCRIPTION + +This trait provides native delegation methods for numbers. All of the +operations correspond to arithmetic operations like addition or +multiplication. + +=head1 DEFAULT TYPE + +If you don't provide an C<isa> value for your attribute, it will default to +C<Num>. + +=head1 PROVIDED METHODS + +All of these methods modify the attribute's value in place. All methods return +the new value. + +=over 4 + +=item * B<add($value)> + +Adds the current value of the attribute to C<$value>. + +=item * B<sub($value)> + +Subtracts C<$value> from the current value of the attribute. + +=item * B<mul($value)> + +Multiplies the current value of the attribute by C<$value>. + +=item * B<div($value)> + +Divides the current value of the attribute by C<$value>. + +=item * B<mod($value)> + +Returns the current value of the attribute modulo C<$value>. + +=item * B<abs> + +Sets the current value of the attribute to its absolute value. + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Attribute/Native/Trait/String.pm b/lib/Moose/Meta/Attribute/Native/Trait/String.pm new file mode 100644 index 0000000..c919f3a --- /dev/null +++ b/lib/Moose/Meta/Attribute/Native/Trait/String.pm @@ -0,0 +1,187 @@ +package Moose::Meta::Attribute::Native::Trait::String; +our $VERSION = '2.1405'; + +use Moose::Role; +with 'Moose::Meta::Attribute::Native::Trait'; + +sub _helper_type { 'Str' } + +no Moose::Role; + +1; + +# ABSTRACT: Helper trait for Str attributes + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Attribute::Native::Trait::String - Helper trait for Str attributes + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + package MyHomePage; + use Moose; + + has 'text' => ( + traits => ['String'], + is => 'rw', + isa => 'Str', + default => q{}, + handles => { + add_text => 'append', + replace_text => 'replace', + }, + ); + + my $page = MyHomePage->new(); + $page->add_text("foo"); # same as $page->text($page->text . "foo"); + +=head1 DESCRIPTION + +This trait provides native delegation methods for strings. + +=head1 DEFAULT TYPE + +If you don't provide an C<isa> value for your attribute, it will default to +C<Str>. + +=head1 PROVIDED METHODS + +=over 4 + +=item * B<inc> + +Increments the value stored in this slot using the magical string autoincrement +operator. Note that Perl doesn't provide analogous behavior in C<-->, so +C<dec> is not available. This method returns the new value. + +This method does not accept any arguments. + +=item * B<append($string)> + +Appends to the string, like C<.=>, and returns the new value. + +This method requires a single argument. + +=item * B<prepend($string)> + +Prepends to the string and returns the new value. + +This method requires a single argument. + +=item * B<replace($pattern, $replacement)> + +Performs a regexp substitution (L<perlop/s>). There is no way to provide the +C<g> flag, but code references will be accepted for the replacement, causing +the regex to be modified with a single C<e>. C</smxi> can be applied using the +C<qr> operator. This method returns the new value. + +This method requires two arguments. + +=item * B<match($pattern)> + +Runs the regex against the string and returns the matching value(s). + +This method requires a single argument. + +=item * B<chop> + +Just like L<perlfunc/chop>. This method returns the chopped character. + +This method does not accept any arguments. + +=item * B<chomp> + +Just like L<perlfunc/chomp>. This method returns the number of characters +removed. + +This method does not accept any arguments. + +=item * B<clear> + +Sets the string to the empty string (not the value passed to C<default>). + +This method does not have a defined return value. + +This method does not accept any arguments. + +=item * B<length> + +Just like L<perlfunc/length>, returns the length of the string. + +=item * B<substr> + +This acts just like L<perlfunc/substr>. When called as a writer, it returns +the substring that was replaced, just like the Perl builtin. + +This method requires at least one argument, and accepts no more than three. + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm new file mode 100644 index 0000000..fafd2c5 --- /dev/null +++ b/lib/Moose/Meta/Class.pm @@ -0,0 +1,1002 @@ +package Moose::Meta::Class; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Class::MOP; +use Data::OptList; +use List::Util 1.33 qw( any first ); +use List::MoreUtils qw( uniq first_index ); +use Scalar::Util 'blessed'; + +use Moose::Meta::Method::Overridden; +use Moose::Meta::Method::Augmented; +use Moose::Meta::Class::Immutable::Trait; +use Moose::Meta::Method::Constructor; +use Moose::Meta::Method::Destructor; +use Moose::Meta::Method::Meta; +use Moose::Util 'throw_exception'; +use Class::MOP::MiniTrait; + +use parent 'Class::MOP::Class'; + +Class::MOP::MiniTrait::apply(__PACKAGE__, 'Moose::Meta::Object::Trait'); + +__PACKAGE__->meta->add_attribute('roles' => ( + reader => 'roles', + default => sub { [] }, + Class::MOP::_definition_context(), +)); + +__PACKAGE__->meta->add_attribute('role_applications' => ( + reader => '_get_role_applications', + default => sub { [] }, + Class::MOP::_definition_context(), +)); + +__PACKAGE__->meta->add_attribute( + Class::MOP::Attribute->new('immutable_trait' => ( + accessor => "immutable_trait", + default => 'Moose::Meta::Class::Immutable::Trait', + Class::MOP::_definition_context(), + )) +); + +__PACKAGE__->meta->add_attribute('constructor_class' => ( + accessor => 'constructor_class', + default => 'Moose::Meta::Method::Constructor', + Class::MOP::_definition_context(), +)); + +__PACKAGE__->meta->add_attribute('destructor_class' => ( + accessor => 'destructor_class', + default => 'Moose::Meta::Method::Destructor', + Class::MOP::_definition_context(), +)); + +sub initialize { + my $class = shift; + my @args = @_; + unshift @args, 'package' if @args % 2; + my %opts = @args; + my $package = delete $opts{package}; + return Class::MOP::get_metaclass_by_name($package) + || $class->SUPER::initialize($package, + 'attribute_metaclass' => 'Moose::Meta::Attribute', + 'method_metaclass' => 'Moose::Meta::Method', + 'instance_metaclass' => 'Moose::Meta::Instance', + %opts, + ); +} + +sub create { + my $class = shift; + my @args = @_; + + unshift @args, 'package' if @args % 2 == 1; + my %options = @args; + + (ref $options{roles} eq 'ARRAY') + || throw_exception( RolesInCreateTakesAnArrayRef => params => \%options ) + if exists $options{roles}; + + my $package = delete $options{package}; + my $roles = delete $options{roles}; + + my $new_meta = $class->SUPER::create($package, %options); + + if ($roles) { + Moose::Util::apply_all_roles( $new_meta, @$roles ); + } + + return $new_meta; +} + +sub _meta_method_class { 'Moose::Meta::Method::Meta' } + +sub _anon_package_prefix { 'Moose::Meta::Class::__ANON__::SERIAL::' } + +sub _anon_cache_key { + my $class = shift; + my %options = @_; + + my $superclass_key = join('|', + map { $_->[0] } @{ Data::OptList::mkopt($options{superclasses} || []) } + ); + + my $roles = Data::OptList::mkopt(($options{roles} || []), { + moniker => 'role', + val_test => sub { ref($_[0]) eq 'HASH' }, + }); + + my @role_keys; + for my $role_spec (@$roles) { + my ($role, $params) = @$role_spec; + $params = { %$params } if $params; + + my $key = blessed($role) ? $role->name : $role; + + if ($params && %$params) { + my $alias = delete $params->{'-alias'} + || delete $params->{'alias'} + || {}; + my $excludes = delete $params->{'-excludes'} + || delete $params->{'excludes'} + || []; + $excludes = [$excludes] unless ref($excludes) eq 'ARRAY'; + + if (%$params) { + warn "Roles with parameters cannot be cached. Consider " + . "applying the parameters before calling " + . "create_anon_class, or using 'weaken => 0' instead"; + return; + } + + my $alias_key = join('%', + map { $_ => $alias->{$_} } sort keys %$alias + ); + my $excludes_key = join('%', + sort @$excludes + ); + $key .= '<' . join('+', 'a', $alias_key, 'e', $excludes_key) . '>'; + } + + push @role_keys, $key; + } + + my $role_key = join('|', sort @role_keys); + + # Makes something like Super::Class|Super::Class::2=Role|Role::1 + return join('=', $superclass_key, $role_key); +} + +sub reinitialize { + my $self = shift; + my $pkg = shift; + + my $meta = blessed $pkg ? $pkg : Class::MOP::class_of($pkg); + + my %existing_classes; + if ($meta) { + %existing_classes = map { $_ => $meta->$_() } qw( + attribute_metaclass + method_metaclass + wrapped_method_metaclass + instance_metaclass + constructor_class + destructor_class + ); + } + + return $self->SUPER::reinitialize( + $pkg, + %existing_classes, + @_, + ); +} + +sub add_role { + my ($self, $role) = @_; + (blessed($role) && $role->isa('Moose::Meta::Role')) + || throw_exception( AddRoleTakesAMooseMetaRoleInstance => role_to_be_added => $role, + class_name => $self->name, + ); + 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')) + || throw_exception( InvalidRoleApplication => class_name => $self->name, + application => $application, + ); + + push @{$self->_get_role_applications} => $application; +} + +sub calculate_all_roles { + my $self = shift; + my %seen; + grep { !$seen{$_->name}++ } map { $_->calculate_all_roles } @{ $self->roles }; +} + +sub _roles_with_inheritance { + my $self = shift; + my %seen; + grep { !$seen{$_->name}++ } + map { Class::MOP::class_of($_)->can('roles') + ? @{ Class::MOP::class_of($_)->roles } + : () } + $self->linearized_isa; +} + +sub calculate_all_roles_with_inheritance { + my $self = shift; + my %seen; + grep { !$seen{$_->name}++ } + map { Class::MOP::class_of($_)->can('calculate_all_roles') + ? Class::MOP::class_of($_)->calculate_all_roles + : () } + $self->linearized_isa; +} + +sub does_role { + my ($self, $role_name) = @_; + + (defined $role_name) + || throw_exception( RoleNameRequired => class_name => $self->name ); + + foreach my $class ($self->class_precedence_list) { + 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); + } + } + return 0; +} + +sub excludes_role { + my ($self, $role_name) = @_; + + (defined $role_name) + || throw_exception( RoleNameRequired => class_name => $self->name ); + + foreach my $class ($self->class_precedence_list) { + 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); + } + } + return 0; +} + +sub new_object { + my $self = shift; + my $params = @_ == 1 ? $_[0] : {@_}; + my $object = $self->SUPER::new_object($params); + + $self->_call_all_triggers($object, $params); + + $object->BUILDALL($params) if $object->can('BUILDALL'); + + return $object; +} + +sub _call_all_triggers { + my ($self, $object, $params) = @_; + + foreach my $attr ( $self->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->( + $object, + ( + $attr->should_coerce + ? $attr->get_read_method_ref->($object) + : $params->{$init_arg} + ), + ); + } +} + +sub _generate_fallback_constructor { + my $self = shift; + my ($class) = @_; + return $class . '->Moose::Object::new(@_)' +} + +sub _inline_params { + my $self = shift; + my ($params, $class) = @_; + return ( + 'my ' . $params . ' = ', + $self->_inline_BUILDARGS($class, '@_'), + ';', + ); +} + +sub _inline_BUILDARGS { + my $self = shift; + my ($class, $args) = @_; + + my $buildargs = $self->find_method_by_name("BUILDARGS"); + + if ($args eq '@_' + && (!$buildargs or $buildargs->body == \&Moose::Object::BUILDARGS)) { + return ( + 'do {', + 'my $params;', + 'if (scalar @_ == 1) {', + 'if (!defined($_[0]) || ref($_[0]) ne \'HASH\') {', + $self->_inline_throw_exception( + 'SingleParamsToNewMustBeHashRef' + ) . ';', + '}', + '$params = { %{ $_[0] } };', + '}', + 'elsif (@_ % 2) {', + 'Carp::carp(', + '"The new() method for ' . $class . ' expects a ' + . 'hash reference or a key/value list. You passed an ' + . 'odd number of arguments"', + ');', + '$params = {@_, undef};', + '}', + 'else {', + '$params = {@_};', + '}', + '$params;', + '}', + ); + } + else { + return $class . '->BUILDARGS(' . $args . ')'; + } +} + +sub _inline_slot_initializer { + my $self = shift; + my ($attr, $idx) = @_; + + return ( + '## ' . $attr->name, + $self->_inline_check_required_attr($attr), + $self->SUPER::_inline_slot_initializer(@_), + ); +} + +sub _inline_check_required_attr { + my $self = shift; + my ($attr) = @_; + + return unless defined $attr->init_arg; + return unless $attr->can('is_required') && $attr->is_required; + return if $attr->has_default || $attr->has_builder; + + return ( + 'if (!exists $params->{\'' . $attr->init_arg . '\'}) {', + $self->_inline_throw_exception( + AttributeIsRequired => + 'params => $params, '. + 'class_name => $class_name, '. + 'attribute_name => "'.quotemeta($attr->name).'"' + ).';', + '}', + ); +} + +# XXX: these two are duplicated from cmop, because we have to pass the tc stuff +# through to _inline_set_value - this should probably be fixed, but i'm not +# quite sure how. -doy +sub _inline_init_attr_from_constructor { + my $self = shift; + my ($attr, $idx) = @_; + + my @initial_value = $attr->_inline_set_value( + '$instance', + '$params->{\'' . $attr->init_arg . '\'}', + '$type_constraint_bodies[' . $idx . ']', + '$type_coercions[' . $idx . ']', + '$type_constraint_messages[' . $idx . ']', + 'for constructor', + ); + + push @initial_value, ( + '$attrs->[' . $idx . ']->set_initial_value(', + '$instance,', + $attr->_inline_instance_get('$instance'), + ');', + ) if $attr->has_initializer; + + return @initial_value; +} + +sub _inline_init_attr_from_default { + my $self = shift; + my ($attr, $idx) = @_; + + return if $attr->can('is_lazy') && $attr->is_lazy; + my $default = $self->_inline_default_value($attr, $idx); + return unless $default; + + my @initial_value = ( + 'my $default = ' . $default . ';', + $attr->_inline_set_value( + '$instance', + '$default', + '$type_constraint_bodies[' . $idx . ']', + '$type_coercions[' . $idx . ']', + '$type_constraint_messages[' . $idx . ']', + 'for constructor', + ), + ); + + push @initial_value, ( + '$attrs->[' . $idx . ']->set_initial_value(', + '$instance,', + $attr->_inline_instance_get('$instance'), + ');', + ) if $attr->has_initializer; + + return @initial_value; +} + +sub _inline_extra_init { + my $self = shift; + return ( + $self->_inline_triggers, + $self->_inline_BUILDALL, + ); +} + +sub _inline_triggers { + my $self = shift; + my @trigger_calls; + + my @attrs = sort { $a->name cmp $b->name } $self->get_all_attributes; + for my $i (0 .. $#attrs) { + my $attr = $attrs[$i]; + + next unless $attr->can('has_trigger') && $attr->has_trigger; + + my $init_arg = $attr->init_arg; + next unless defined $init_arg; + + push @trigger_calls, + 'if (exists $params->{\'' . $init_arg . '\'}) {', + '$triggers->[' . $i . ']->(', + '$instance,', + $attr->_inline_instance_get('$instance') . ',', + ');', + '}'; + } + + return @trigger_calls; +} + +sub _inline_BUILDALL { + my $self = shift; + + my @methods = reverse $self->find_all_methods_by_name('BUILD'); + my @BUILD_calls; + + foreach my $method (@methods) { + push @BUILD_calls, + '$instance->' . $method->{class} . '::BUILD($params);'; + } + + return @BUILD_calls; +} + +sub _eval_environment { + my $self = shift; + + my @attrs = sort { $a->name cmp $b->name } $self->get_all_attributes; + + my $triggers = [ + map { $_->can('has_trigger') && $_->has_trigger ? $_->trigger : undef } + @attrs + ]; + + # We need to check if the attribute ->can('type_constraint') + # since we may be trying to immutabilize a Moose meta class, + # which in turn has attributes which are Class::MOP::Attribute + # objects, rather than Moose::Meta::Attribute. And + # Class::MOP::Attribute attributes have no type constraints. + # However we need to make sure we leave an undef value there + # because the inlined code is using the index of the attributes + # to determine where to find the type constraint + + my @type_constraints = map { + $_->can('type_constraint') ? $_->type_constraint : undef + } @attrs; + + my @type_constraint_bodies = map { + defined $_ ? $_->_compiled_type_constraint : undef; + } @type_constraints; + + my @type_coercions = map { + defined $_ && $_->has_coercion + ? $_->coercion->_compiled_type_coercion + : undef + } @type_constraints; + + my @type_constraint_messages = map { + defined $_ + ? ($_->has_message ? $_->message : $_->_default_message) + : undef + } @type_constraints; + + return { + %{ $self->SUPER::_eval_environment }, + ((any { defined && $_->has_initializer } @attrs) + ? ('$attrs' => \[@attrs]) + : ()), + '$triggers' => \$triggers, + '@type_coercions' => \@type_coercions, + '@type_constraint_bodies' => \@type_constraint_bodies, + '@type_constraint_messages' => \@type_constraint_messages, + ( map { defined($_) ? %{ $_->inline_environment } : () } + @type_constraints ), + # pretty sure this is only going to be closed over if you use a custom + # error class at this point, but we should still get rid of this + # at some point + '$meta' => \$self, + '$class_name' => \($self->name), + }; +} + +sub superclasses { + my $self = shift; + my $supers = Data::OptList::mkopt(\@_); + foreach my $super (@{ $supers }) { + my ($name, $opts) = @{ $super }; + Moose::Util::_load_user_class($name, $opts); + my $meta = Class::MOP::class_of($name); + throw_exception( CanExtendOnlyClasses => role_name => $meta->name ) + if $meta && $meta->isa('Moose::Meta::Role') + } + return $self->SUPER::superclasses(map { $_->[0] } @{ $supers }); +} + +### --------------------------------------------- + +sub add_attribute { + my $self = shift; + my $attr = + (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute') + ? $_[0] + : $self->_process_attribute(@_)); + $self->SUPER::add_attribute($attr); + # it may be a Class::MOP::Attribute, theoretically, which doesn't have + # 'bare' and doesn't implement this method + if ($attr->can('_check_associated_methods')) { + $attr->_check_associated_methods; + } + return $attr; +} + +sub add_override_method_modifier { + my ($self, $name, $method, $_super_package) = @_; + + my $existing_method = $self->get_method($name); + (!$existing_method) + || throw_exception( CannotOverrideLocalMethodIsPresent => class_name => $self->name, + method => $existing_method, + ); + $self->add_method($name => Moose::Meta::Method::Overridden->new( + method => $method, + class => $self, + package => $_super_package, # need this for roles + name => $name, + )); +} + +sub add_augment_method_modifier { + my ($self, $name, $method) = @_; + my $existing_method = $self->get_method($name); + throw_exception( CannotAugmentIfLocalMethodPresent => class_name => $self->name, + method => $existing_method, + ) + if( $existing_method ); + + $self->add_method($name => Moose::Meta::Method::Augmented->new( + method => $method, + class => $self, + name => $name, + )); +} + +## Private Utility methods ... + +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::Overridden'); + } + return undef; +} + +## Metaclass compatibility + +sub _base_metaclasses { + my $self = shift; + my %metaclasses = $self->SUPER::_base_metaclasses; + for my $class (keys %metaclasses) { + $metaclasses{$class} =~ s/^Class::MOP/Moose::Meta/; + } + return ( + %metaclasses, + ); +} + +sub _fix_class_metaclass_incompatibility { + my $self = shift; + my ($super_meta) = @_; + + $self->SUPER::_fix_class_metaclass_incompatibility(@_); + + if ($self->_class_metaclass_can_be_made_compatible($super_meta)) { + ($self->is_pristine) + || throw_exception( CannotFixMetaclassCompatibility => class => $self, + superclass => $super_meta + ); + my $super_meta_name = $super_meta->_real_ref_name; + my $class_meta_subclass_meta_name = Moose::Util::_reconcile_roles_for_metaclass(blessed($self), $super_meta_name); + my $new_self = $class_meta_subclass_meta_name->reinitialize( + $self->name, + ); + + $self->_replace_self( $new_self, $class_meta_subclass_meta_name ); + } +} + +sub _fix_single_metaclass_incompatibility { + my $self = shift; + my ($metaclass_type, $super_meta) = @_; + + $self->SUPER::_fix_single_metaclass_incompatibility(@_); + + if ($self->_single_metaclass_can_be_made_compatible($super_meta, $metaclass_type)) { + ($self->is_pristine) + || throw_exception( CannotFixMetaclassCompatibility => class => $self, + superclass => $super_meta, + metaclass_type => $metaclass_type + ); + my $super_meta_name = $super_meta->_real_ref_name; + my $class_specific_meta_subclass_meta_name = Moose::Util::_reconcile_roles_for_metaclass($self->$metaclass_type, $super_meta->$metaclass_type); + my $new_self = $super_meta->reinitialize( + $self->name, + $metaclass_type => $class_specific_meta_subclass_meta_name, + ); + + $self->_replace_self( $new_self, $super_meta_name ); + } +} + +sub _replace_self { + my $self = shift; + my ( $new_self, $new_class) = @_; + + %$self = %$new_self; + bless $self, $new_class; + + # 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. + my $weaken = Class::MOP::metaclass_is_weak( $self->name ); + Class::MOP::store_metaclass_by_name( $self->name, $self ); + Class::MOP::weaken_metaclass( $self->name ) if $weaken; +} + +sub _process_attribute { + my ( $self, $name, @args ) = @_; + + @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH'; + + if (($name || '') =~ /^\+(.*)/) { + return $self->_process_inherited_attribute($1, @args); + } + else { + return $self->_process_new_attribute($name, @args); + } +} + +sub _process_new_attribute { + my ( $self, $name, @args ) = @_; + + $self->attribute_metaclass->interpolate_class_and_new($name, @args); +} + +sub _process_inherited_attribute { + my ($self, $attr_name, %options) = @_; + + my $inherited_attr = $self->find_attribute_by_name($attr_name); + (defined $inherited_attr) + || throw_exception( NoAttributeFoundInSuperClass => class_name => $self->name, + attribute_name => $attr_name, + params => \%options + ); + if ($inherited_attr->isa('Moose::Meta::Attribute')) { + return $inherited_attr->clone_and_inherit_options(%options); + } + else { + # NOTE: + # kind of a kludge to handle Class::MOP::Attributes + return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options); + } +} + +# reinitialization support + +sub _restore_metaobjects_from { + my $self = shift; + my ($old_meta) = @_; + + $self->SUPER::_restore_metaobjects_from($old_meta); + + for my $role ( @{ $old_meta->roles } ) { + $self->add_role($role); + } + + for my $application ( @{ $old_meta->_get_role_applications } ) { + $application->class($self); + $self->add_role_application ($application); + } +} + +## Immutability + +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 _fixup_attributes_after_rebless { + my $self = shift; + my ($instance, $rebless_from, %params) = @_; + + $self->SUPER::_fixup_attributes_after_rebless( + $instance, + $rebless_from, + %params + ); + + $self->_call_all_triggers( $instance, \%params ); +} + +## ------------------------------------------------- + +our $error_level; + +sub _inline_throw_exception { + my ( $self, $exception_type, $throw_args ) = @_; + return 'die Module::Runtime::use_module("Moose::Exception::' . $exception_type . '")->new(' . ($throw_args || '') . ')'; +} + +1; + +# ABSTRACT: The Moose metaclass + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Class - The Moose metaclass + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class is a subclass of L<Class::MOP::Class> that provides +additional Moose-specific functionality. + +To really understand this class, you will need to start with the +L<Class::MOP::Class> 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<Moose::Meta::Class> is a subclass of L<Class::MOP::Class>. + +=head1 METHODS + +=over 4 + +=item B<< Moose::Meta::Class->initialize($package_name, %options) >> + +This overrides the parent's method in order to provide its own +defaults for the C<attribute_metaclass>, C<instance_metaclass>, and +C<method_metaclass> options. + +These all default to the appropriate Moose class. + +=item B<< Moose::Meta::Class->create($package_name, %options) >> + +This overrides the parent's method in order to accept a C<roles> +option. This should be an array reference containing roles +that the class does, each optionally followed by a hashref of options +(C<-excludes> and C<-alias>). + + my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] ); + +=item B<< Moose::Meta::Class->create_anon_class >> + +This overrides the parent's method to accept a C<roles> option, just +as C<create> does. + +It also accepts a C<cache> option. If this is C<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. + + my $metaclass = Moose::Meta::Class->create_anon_class( + superclasses => ['Foo'], + roles => [qw/Some Roles Go Here/], + cache => 1, + ); + +Each entry in both the C<superclasses> and the C<roles> option can be +followed by a hash reference with arguments. The C<superclasses> +option can be supplied with a L<-version|Class::MOP/Class Loading +Options> option that ensures the loaded superclass satisfies the +required version. The C<role> option also takes the C<-version> as an +argument, but the option hash reference can also contain any other +role relevant values like exclusions or parameterized role arguments. + +=item B<< $metaclass->new_object(%params) >> + +This overrides the parent's method in order to add support for +attribute triggers. + +=item B<< $metaclass->superclasses(@superclasses) >> + +This is the accessor allowing you to read or change the parents of +the class. + +Each superclass can be followed by a hash reference containing a +L<-version|Class::MOP/Class Loading Options> value. If the version +requirement is not satisfied an error will be thrown. + +When you pass classes to this method, we will attempt to load them if they are +not already loaded. + +=item B<< $metaclass->add_override_method_modifier($name, $sub) >> + +This adds an C<override> method modifier to the package. + +=item B<< $metaclass->add_augment_method_modifier($name, $sub) >> + +This adds an C<augment> method modifier to the package. + +=item B<< $metaclass->calculate_all_roles >> + +This will return a unique array of L<Moose::Meta::Role> instances +which are attached to this class. + +=item B<< $metaclass->calculate_all_roles_with_inheritance >> + +This will return a unique array of L<Moose::Meta::Role> instances +which are attached to this class, and each of this class's ancestors. + +=item B<< $metaclass->add_role($role) >> + +This takes a L<Moose::Meta::Role> object, and adds it to the class's +list of roles. This I<does not> actually apply the role to the class. + +=item B<< $metaclass->role_applications >> + +Returns a list of L<Moose::Meta::Role::Application::ToClass> +objects, which contain the arguments to role application. + +=item B<< $metaclass->add_role_application($application) >> + +This takes a L<Moose::Meta::Role::Application::ToClass> object, and +adds it to the class's list of role applications. This I<does not> +actually apply any role to the class; it is only for tracking role +applications. + +=item B<< $metaclass->does_role($role) >> + +This returns a boolean indicating whether or not the class does the specified +role. The role provided can be either a role name or a L<Moose::Meta::Role> +object. This tests both the class and its parents. + +=item B<< $metaclass->excludes_role($role_name) >> + +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<< $metaclass->add_attribute($attr_name, %params|$params) >> + +This overrides the parent's method in order to allow the parameters to +be provided as a hash reference. + +=item B<< $metaclass->constructor_class($class_name) >> + +=item B<< $metaclass->destructor_class($class_name) >> + +These are the names of classes used when making a class immutable. These +default to L<Moose::Meta::Method::Constructor> and +L<Moose::Meta::Method::Destructor> respectively. These accessors are +read-write, so you can use them to change the class name. + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Class/Immutable/Trait.pm b/lib/Moose/Meta/Class/Immutable/Trait.pm new file mode 100644 index 0000000..8dba57a --- /dev/null +++ b/lib/Moose/Meta/Class/Immutable/Trait.pm @@ -0,0 +1,123 @@ +package Moose::Meta::Class::Immutable::Trait; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Class::MOP; +use Scalar::Util qw( blessed ); + +use parent 'Class::MOP::Class::Immutable::Trait'; + +use Moose::Util 'throw_exception'; + +sub add_role { $_[1]->_immutable_cannot_call } + +sub calculate_all_roles { + my $orig = shift; + my $self = shift; + @{ $self->{__immutable}{calculate_all_roles} ||= [ $self->$orig ] }; +} + +sub calculate_all_roles_with_inheritance { + my $orig = shift; + my $self = shift; + @{ $self->{__immutable}{calculate_all_roles_with_inheritance} ||= [ $self->$orig ] }; +} + +sub does_role { + shift; + my $self = shift; + my $role = shift; + + (defined $role) + || throw_exception( RoleNameRequired => class_name => $self->name ); + + $self->{__immutable}{does_role} ||= { map { $_->name => 1 } $self->calculate_all_roles_with_inheritance }; + + my $name = blessed $role ? $role->name : $role; + + return $self->{__immutable}{does_role}{$name}; +} + +1; + +# ABSTRACT: Implements immutability for metaclass objects + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Class::Immutable::Trait - Implements immutability for metaclass objects + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class makes some Moose-specific metaclass methods immutable. This +is deep guts. + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Instance.pm b/lib/Moose/Meta/Instance.pm new file mode 100644 index 0000000..ee412b4 --- /dev/null +++ b/lib/Moose/Meta/Instance.pm @@ -0,0 +1,109 @@ +package Moose::Meta::Instance; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Class::MOP::MiniTrait; + +use parent 'Class::MOP::Instance'; + +Class::MOP::MiniTrait::apply(__PACKAGE__, 'Moose::Meta::Object::Trait'); + +1; + +# ABSTRACT: The Moose Instance metaclass + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Instance - The Moose Instance metaclass + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + # nothing to see here + +=head1 DESCRIPTION + +This class provides the low level data storage abstractions for +attributes. + +Using this API directly in your own code violates encapsulation, and +we recommend that you use the appropriate APIs in +L<Moose::Meta::Class> and L<Moose::Meta::Attribute> instead. Those +APIs in turn call the methods in this class as appropriate. + +At present, this is an empty subclass of L<Class::MOP::Instance>, so +you should see that class for all API details. + +=head1 INHERITANCE + +C<Moose::Meta::Instance> is a subclass of L<Class::MOP::Instance>. + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Method.pm b/lib/Moose/Meta/Method.pm new file mode 100644 index 0000000..e0bc667 --- /dev/null +++ b/lib/Moose/Meta/Method.pm @@ -0,0 +1,100 @@ +package Moose::Meta::Method; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Class::MOP::MiniTrait; + +use parent 'Class::MOP::Method'; + +Class::MOP::MiniTrait::apply(__PACKAGE__, 'Moose::Meta::Object::Trait'); + +1; + +# ABSTRACT: A Moose Method metaclass + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Method - A Moose Method metaclass + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class is a subclass of L<Class::MOP::Method> that provides +additional Moose-specific functionality, all of which is private. + +To understand this class, you should read the the L<Class::MOP::Method> +documentation. + +=head1 INHERITANCE + +C<Moose::Meta::Method> is a subclass of L<Class::MOP::Method>. + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Method/Accessor.pm b/lib/Moose/Meta/Method/Accessor.pm new file mode 100644 index 0000000..3b30b2d --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor.pm @@ -0,0 +1,208 @@ +package Moose::Meta::Method::Accessor; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Try::Tiny; + +use parent 'Moose::Meta::Method', + 'Class::MOP::Method::Accessor'; + +use Moose::Util 'throw_exception'; + +# multiple inheritance is terrible +sub new { + goto &Class::MOP::Method::Accessor::new; +} + +sub _new { + goto &Class::MOP::Method::Accessor::_new; +} + +sub _error_thrower { + my $self = shift; + return $self->associated_attribute + if ref($self) && defined($self->associated_attribute); + return $self->SUPER::_error_thrower; +} + +sub _compile_code { + my $self = shift; + my @args = @_; + try { + $self->SUPER::_compile_code(@args); + } + catch { + throw_exception( CouldNotCreateWriter => attribute => $self->associated_attribute, + error => $_, + instance => $self + ); + }; +} + +sub _eval_environment { + my $self = shift; + return $self->associated_attribute->_eval_environment; +} + +sub _instance_is_inlinable { + my $self = shift; + return $self->associated_attribute->associated_class->instance_metaclass->is_inlinable; +} + +sub _generate_reader_method { + my $self = shift; + $self->_instance_is_inlinable ? $self->_generate_reader_method_inline(@_) + : $self->SUPER::_generate_reader_method(@_); +} + +sub _generate_writer_method { + my $self = shift; + $self->_instance_is_inlinable ? $self->_generate_writer_method_inline(@_) + : $self->SUPER::_generate_writer_method(@_); +} + +sub _generate_accessor_method { + my $self = shift; + $self->_instance_is_inlinable ? $self->_generate_accessor_method_inline(@_) + : $self->SUPER::_generate_accessor_method(@_); +} + +sub _generate_predicate_method { + my $self = shift; + $self->_instance_is_inlinable ? $self->_generate_predicate_method_inline(@_) + : $self->SUPER::_generate_predicate_method(@_); +} + +sub _generate_clearer_method { + my $self = shift; + $self->_instance_is_inlinable ? $self->_generate_clearer_method_inline(@_) + : $self->SUPER::_generate_clearer_method(@_); +} + +sub _writer_value_needs_copy { + shift->associated_attribute->_writer_value_needs_copy(@_); +} + +sub _inline_tc_code { + shift->associated_attribute->_inline_tc_code(@_); +} + +sub _inline_check_coercion { + shift->associated_attribute->_inline_check_coercion(@_); +} + +sub _inline_check_constraint { + shift->associated_attribute->_inline_check_constraint(@_); +} + +sub _inline_check_lazy { + shift->associated_attribute->_inline_check_lazy(@_); +} + +sub _inline_store_value { + shift->associated_attribute->_inline_instance_set(@_) . ';'; +} + +sub _inline_get_old_value_for_trigger { + shift->associated_attribute->_inline_get_old_value_for_trigger(@_); +} + +sub _inline_trigger { + shift->associated_attribute->_inline_trigger(@_); +} + +sub _get_value { + shift->associated_attribute->_inline_instance_get(@_); +} + +sub _has_value { + shift->associated_attribute->_inline_instance_has(@_); +} + +1; + +# ABSTRACT: A Moose Method metaclass for accessors + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Method::Accessor - A Moose Method metaclass for accessors + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class is a subclass of L<Class::MOP::Method::Accessor> that +provides additional Moose-specific functionality, all of which is +private. + +To understand this class, you should read the the +L<Class::MOP::Method::Accessor> documentation. + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Method/Accessor/Native.pm b/lib/Moose/Meta/Method/Accessor/Native.pm new file mode 100644 index 0000000..01a3fee --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native.pm @@ -0,0 +1,157 @@ +package Moose::Meta::Method::Accessor::Native; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Carp qw( confess ); +use Scalar::Util qw( blessed ); + +use Moose::Role; + +use Moose::Util 'throw_exception'; + +around new => sub { + my $orig = shift; + my $class = shift; + my %options = @_; + + $options{curried_arguments} = [] + unless exists $options{curried_arguments}; + + throw_exception( MustSupplyArrayRefAsCurriedArguments => params => \%options, + class_name => $class + ) + unless $options{curried_arguments} + && ref($options{curried_arguments}) eq 'ARRAY'; + + my $attr_context = $options{attribute}->definition_context; + my $desc = 'native delegation method '; + $desc .= $options{attribute}->associated_class->name; + $desc .= '::' . $options{name}; + $desc .= " ($options{delegate_to_method})"; + $desc .= " of attribute " . $options{attribute}->name; + $options{definition_context} = { + %{ $attr_context || {} }, + description => $desc, + }; + + $options{accessor_type} = 'native'; + + return $class->$orig(%options); +}; + +sub _new { + my $class = shift; + my $options = @_ == 1 ? $_[0] : {@_}; + + return bless $options, $class; +} + +sub root_types { (shift)->{'root_types'} } + +sub _initialize_body { + my $self = shift; + + $self->{'body'} = $self->_compile_code( [$self->_generate_method] ); + + return; +} + +sub _inline_curried_arguments { + my $self = shift; + + return unless @{ $self->curried_arguments }; + + return 'unshift @_, @curried;'; +} + +sub _inline_check_argument_count { + my $self = shift; + + my @code; + + if (my $min = $self->_minimum_arguments) { + push @code, ( + 'if (@_ < ' . $min . ') {', + $self->_inline_throw_exception( MethodExpectsMoreArgs => + 'method_name => "'.$self->delegate_to_method.'",'. + "minimum_args => ".$min, + ) . ';', + '}', + ); + } + + if (defined(my $max = $self->_maximum_arguments)) { + push @code, ( + 'if (@_ > ' . $max . ') {', + $self->_inline_throw_exception( MethodExpectsFewerArgs => + 'method_name => "'.$self->delegate_to_method.'",'. + 'maximum_args => '.$max, + ) . ';', + '}', + ); + } + + return @code; +} + +sub _inline_return_value { + my $self = shift; + my ($slot_access, $for_writer) = @_; + + return 'return ' . $self->_return_value($slot_access, $for_writer) . ';'; +} + +sub _minimum_arguments { 0 } +sub _maximum_arguments { undef } + +override _get_value => sub { + my $self = shift; + my ($instance) = @_; + + return $self->_slot_access_can_be_inlined + ? super() + : $instance . '->$reader'; +}; + +override _inline_store_value => sub { + my $self = shift; + my ($instance, $value) = @_; + + return $self->_slot_access_can_be_inlined + ? super() + : $instance . '->$writer(' . $value . ');'; +}; + +override _eval_environment => sub { + my $self = shift; + + my $env = super(); + + $env->{'@curried'} = $self->curried_arguments; + + return $env if $self->_slot_access_can_be_inlined; + + my $reader = $self->associated_attribute->get_read_method_ref; + $reader = $reader->body if blessed $reader; + + $env->{'$reader'} = \$reader; + + my $writer = $self->associated_attribute->get_write_method_ref; + $writer = $writer->body if blessed $writer; + + $env->{'$writer'} = \$writer; + + return $env; +}; + +sub _slot_access_can_be_inlined { + my $self = shift; + + return $self->is_inline && $self->_instance_is_inlinable; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array.pm b/lib/Moose/Meta/Method/Accessor/Native/Array.pm new file mode 100644 index 0000000..d585648 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array.pm @@ -0,0 +1,28 @@ +package Moose::Meta::Method::Accessor::Native::Array; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +sub _inline_check_var_is_valid_index { + my $self = shift; + my ($var) = @_; + + return ( + 'if (!defined(' . $var . ') || ' . $var . ' !~ /^-?\d+$/) {', + $self->_inline_throw_exception( InvalidArgumentToMethod => + 'argument => '.$var.','. + 'method_name => "'.$self->delegate_to_method.'",'. + 'type_of_argument => "integer",'. + 'type => "Int",'. + 'argument_noun => "index"', + ) . ';', + '}', + ); +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/Writer.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/Writer.pm new file mode 100644 index 0000000..e47d940 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/Writer.pm @@ -0,0 +1,27 @@ +package Moose::Meta::Method::Accessor::Native::Array::Writer; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Writer', + 'Moose::Meta::Method::Accessor::Native::Array', + 'Moose::Meta::Method::Accessor::Native::Collection'; + +sub _inline_coerce_new_values { + my $self = shift; + $self->Moose::Meta::Method::Accessor::Native::Collection::_inline_coerce_new_values(@_); +} + +sub _new_members { '@_' } + +sub _copy_old_value { + my $self = shift; + my ($slot_access) = @_; + + return '[ @{(' . $slot_access . ')} ]'; +} + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/accessor.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/accessor.pm new file mode 100644 index 0000000..62af0a5 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/accessor.pm @@ -0,0 +1,56 @@ +package Moose::Meta::Method::Accessor::Native::Array::accessor; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Array::set', + 'Moose::Meta::Method::Accessor::Native::Array::get'; + +sub _inline_process_arguments { + my $self = shift; + $self->Moose::Meta::Method::Accessor::Native::Array::get::_inline_process_arguments(@_); +} + +sub _inline_check_arguments { + my $self = shift; + $self->Moose::Meta::Method::Accessor::Native::Array::get::_inline_check_arguments(@_); +} + +sub _return_value { + my $self = shift; + $self->Moose::Meta::Method::Accessor::Native::Array::get::_return_value(@_); +} + +sub _generate_method { + my $self = shift; + + my $inv = '$self'; + my $slot_access = $self->_get_value($inv); + + return ( + 'sub {', + 'my ' . $inv . ' = shift;', + $self->_inline_curried_arguments, + $self->_inline_check_lazy($inv, '$type_constraint', '$type_coercion', '$type_message'), + # get + 'if (@_ == 1) {', + $self->_inline_check_var_is_valid_index('$_[0]'), + $self->Moose::Meta::Method::Accessor::Native::Array::get::_inline_return_value($slot_access), + '}', + # set + 'else {', + $self->_inline_writer_core($inv, $slot_access), + '}', + '}', + ); +} + +sub _minimum_arguments { 1 } +sub _maximum_arguments { 2 } + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/clear.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/clear.pm new file mode 100644 index 0000000..39913ff --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/clear.pm @@ -0,0 +1,28 @@ +package Moose::Meta::Method::Accessor::Native::Array::clear; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Array::Writer'; + +sub _maximum_arguments { 0 } + +sub _adds_members { 0 } + +sub _potential_value { '[]' } + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return $slot_access . ' = [];'; +} + +sub _return_value { '' } + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/count.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/count.pm new file mode 100644 index 0000000..724db7a --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/count.pm @@ -0,0 +1,22 @@ +package Moose::Meta::Method::Accessor::Native::Array::count; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader'; + +sub _maximum_arguments { 0 } + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return 'scalar @{ (' . $slot_access . ') }'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/delete.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/delete.pm new file mode 100644 index 0000000..bf47e09 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/delete.pm @@ -0,0 +1,50 @@ +package Moose::Meta::Method::Accessor::Native::Array::delete; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Array::Writer'; + +sub _minimum_arguments { 1 } + +sub _maximum_arguments { 1 } + +sub _inline_check_arguments { + my $self = shift; + + return $self->_inline_check_var_is_valid_index('$_[0]'); +} + +sub _adds_members { 0 } + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + return '(do { ' + . 'my @potential = @{ (' . $slot_access . ') }; ' + . '@return = splice @potential, $_[0], 1; ' + . '\@potential; ' + . '})'; +} + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return '@return = splice @{ (' . $slot_access . ') }, $_[0], 1;'; +} + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return '$return[0]'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/elements.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/elements.pm new file mode 100644 index 0000000..59dcc14 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/elements.pm @@ -0,0 +1,22 @@ +package Moose::Meta::Method::Accessor::Native::Array::elements; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader'; + +sub _maximum_arguments { 0 } + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return '@{ (' . $slot_access . ') }'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/first.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/first.pm new file mode 100644 index 0000000..32059f8 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/first.pm @@ -0,0 +1,42 @@ +package Moose::Meta::Method::Accessor::Native::Array::first; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use List::Util (); +use Params::Util (); + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader'; + +sub _minimum_arguments { 1 } + +sub _maximum_arguments { 1 } + +sub _inline_check_arguments { + my $self = shift; + + return ( + 'if (!Params::Util::_CODELIKE($_[0])) {', + $self->_inline_throw_exception( InvalidArgumentToMethod => + 'argument => $_[0],'. + 'method_name => "first",'. + 'type_of_argument => "code reference",'. + 'type => "CodeRef",', + ) . ';', + '}', + ); +} + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return '&List::Util::first($_[0], @{ (' . $slot_access . ') })'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/first_index.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/first_index.pm new file mode 100644 index 0000000..da22266 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/first_index.pm @@ -0,0 +1,42 @@ +package Moose::Meta::Method::Accessor::Native::Array::first_index; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use List::MoreUtils (); +use Params::Util (); + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader'; + +sub _minimum_arguments { 1 } + +sub _maximum_arguments { 1 } + +sub _inline_check_arguments { + my $self = shift; + + return ( + 'if (!Params::Util::_CODELIKE($_[0])) {', + $self->_inline_throw_exception( InvalidArgumentToMethod => + 'argument => $_[0],'. + 'method_name => "first_index",'. + 'type_of_argument => "code reference",'. + 'type => "CodeRef",', + ) . ';', + '}', + ); +} + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return '&List::MoreUtils::first_index($_[0], @{ (' . $slot_access . ') })'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/get.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/get.pm new file mode 100644 index 0000000..3e88930 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/get.pm @@ -0,0 +1,31 @@ +package Moose::Meta::Method::Accessor::Native::Array::get; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Class::MOP::MiniTrait; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader', + 'Moose::Meta::Method::Accessor::Native::Array'; + +sub _minimum_arguments { 1 } + +sub _maximum_arguments { 1 } + +sub _inline_check_arguments { + my $self = shift; + + return $self->_inline_check_var_is_valid_index('$_[0]'); +} + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return $slot_access . '->[ $_[0] ]'; +} + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/grep.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/grep.pm new file mode 100644 index 0000000..c750e5b --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/grep.pm @@ -0,0 +1,41 @@ +package Moose::Meta::Method::Accessor::Native::Array::grep; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Params::Util (); + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader'; + +sub _minimum_arguments { 1 } + +sub _maximum_arguments { 1 } + +sub _inline_check_arguments { + my $self = shift; + + return ( + 'if (!Params::Util::_CODELIKE($_[0])) {', + $self->_inline_throw_exception( InvalidArgumentToMethod => + 'argument => $_[0],'. + 'method_name => "grep",'. + 'type_of_argument => "code reference",'. + 'type => "CodeRef",', + ) . ';', + '}', + ); +} + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return 'grep { $_[0]->() } @{ (' . $slot_access . ') }'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/insert.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/insert.pm new file mode 100644 index 0000000..c085223 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/insert.pm @@ -0,0 +1,58 @@ +package Moose::Meta::Method::Accessor::Native::Array::insert; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Array::Writer'; + +sub _minimum_arguments { 2 } + +sub _maximum_arguments { 2 } + +sub _adds_members { 1 } + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + return '(do { ' + . 'my @potential = @{ (' . $slot_access . ') }; ' + . 'splice @potential, $_[0], 0, $_[1]; ' + . '\@potential; ' + . '})'; +} + +# We need to override this because while @_ can be written to, we cannot write +# directly to $_[1]. +sub _inline_coerce_new_values { + my $self = shift; + + return unless $self->associated_attribute->should_coerce; + + return unless $self->_tc_member_type_can_coerce; + + return '@_ = ($_[0], $member_coercion->($_[1]));'; +}; + +sub _new_members { '$_[1]' } + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return 'splice @{ (' . $slot_access . ') }, $_[0], 0, $_[1];'; +} + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return $slot_access . '->[ $_[0] ]'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/is_empty.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/is_empty.pm new file mode 100644 index 0000000..c57c448 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/is_empty.pm @@ -0,0 +1,22 @@ +package Moose::Meta::Method::Accessor::Native::Array::is_empty; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader'; + +sub _maximum_arguments { 0 } + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return '@{ (' . $slot_access . ') } ? 0 : 1'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/join.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/join.pm new file mode 100644 index 0000000..b06ae3b --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/join.pm @@ -0,0 +1,41 @@ +package Moose::Meta::Method::Accessor::Native::Array::join; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Util (); + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader'; + +sub _minimum_arguments { 1 } + +sub _maximum_arguments { 1 } + +sub _inline_check_arguments { + my $self = shift; + + return ( + 'if (!Moose::Util::_STRINGLIKE0($_[0])) {', + $self->_inline_throw_exception( InvalidArgumentToMethod => + 'argument => $_[0],'. + 'method_name => "join",'. + 'type_of_argument => "string",'. + 'type => "Str",', + ) . ';', + '}', + ); +} + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return 'join $_[0], @{ (' . $slot_access . ') }'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/map.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/map.pm new file mode 100644 index 0000000..59c6225 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/map.pm @@ -0,0 +1,41 @@ +package Moose::Meta::Method::Accessor::Native::Array::map; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Params::Util (); + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader'; + +sub _minimum_arguments { 1 } + +sub _maximum_arguments { 1 } + +sub _inline_check_arguments { + my $self = shift; + + return ( + 'if (!Params::Util::_CODELIKE($_[0])) {', + $self->_inline_throw_exception( InvalidArgumentToMethod => + 'argument => $_[0],'. + 'method_name => "map",'. + 'type_of_argument => "code reference",'. + 'type => "CodeRef",', + ) . ';', + '}', + ); +} + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return 'map { $_[0]->() } @{ (' . $slot_access . ') }'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/natatime.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/natatime.pm new file mode 100644 index 0000000..e72815e --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/natatime.pm @@ -0,0 +1,65 @@ +package Moose::Meta::Method::Accessor::Native::Array::natatime; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use List::MoreUtils (); +use Params::Util (); + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader'; + +sub _minimum_arguments { 1 } + +sub _maximum_arguments { 2 } + +sub _inline_check_arguments { + my $self = shift; + + return ( + 'if (!defined($_[0]) || $_[0] !~ /^\d+$/) {', + $self->_inline_throw_exception( InvalidArgumentToMethod => + 'argument => $_[0],'. + 'method_name => "natatime",'. + 'type_of_argument => "integer",'. + 'type => "Int",'. + 'argument_noun => "n value"', + ) . ';', + '}', + 'if (@_ == 2 && !Params::Util::_CODELIKE($_[1])) {', + $self->_inline_throw_exception( InvalidArgumentToMethod => + 'argument => $_[1],'. + 'method_name => "natatime",'. + 'type_of_argument => "code reference",'. + 'type => "CodeRef",'. + 'ordinal => "second"', + ) . ';', + '}', + ); +} + +sub _inline_return_value { + my $self = shift; + my ($slot_access) = @_; + + return ( + 'my $iter = List::MoreUtils::natatime($_[0], @{ (' . $slot_access . ') });', + 'if ($_[1]) {', + 'while (my @vals = $iter->()) {', + '$_[1]->(@vals);', + '}', + '}', + 'else {', + 'return $iter;', + '}', + ); +} + +# Not called, but needed to satisfy the Reader role +sub _return_value { } + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/pop.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/pop.pm new file mode 100644 index 0000000..a9df36f --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/pop.pm @@ -0,0 +1,47 @@ +package Moose::Meta::Method::Accessor::Native::Array::pop; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Array::Writer'; + +sub _maximum_arguments { 0 } + +sub _adds_members { 0 } + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + return '[ @{ (' . $slot_access . ') } > 1 ' + . '? @{ (' . $slot_access . ') }[0..$#{ (' . $slot_access . ') } - 1] ' + . ': () ]'; +} + +sub _inline_capture_return_value { + my $self = shift; + my ($slot_access) = @_; + + return 'my $old = ' . $slot_access . '->[-1];'; +} + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return 'pop @{ (' . $slot_access . ') };'; +} + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return '$old'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/push.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/push.pm new file mode 100644 index 0000000..eec4344 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/push.pm @@ -0,0 +1,36 @@ +package Moose::Meta::Method::Accessor::Native::Array::push; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Array::Writer'; + +sub _adds_members { 1 } + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + return '[ @{ (' . $slot_access . ') }, @_ ]'; +} + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return 'push @{ (' . $slot_access . ') }, @_;'; +} + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return 'scalar @{ (' . $slot_access . ') }'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/reduce.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/reduce.pm new file mode 100644 index 0000000..12fd9c4 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/reduce.pm @@ -0,0 +1,42 @@ +package Moose::Meta::Method::Accessor::Native::Array::reduce; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use List::Util (); +use Params::Util (); + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader'; + +sub _minimum_arguments { 1 } + +sub _maximum_arguments { 1 } + +sub _inline_check_arguments { + my $self = shift; + + return ( + 'if (!Params::Util::_CODELIKE($_[0])) {', + $self->_inline_throw_exception( InvalidArgumentToMethod => + 'argument => $_[0],'. + 'method_name => "reduce",'. + 'type_of_argument => "code reference",'. + 'type => "CodeRef",', + ) . ';', + '}', + ); +} + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return 'List::Util::reduce { $_[0]->($a, $b) } @{ (' . $slot_access . ') }'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/set.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/set.pm new file mode 100644 index 0000000..b487303 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/set.pm @@ -0,0 +1,64 @@ +package Moose::Meta::Method::Accessor::Native::Array::set; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Array::Writer'; + +sub _minimum_arguments { 2 } + +sub _maximum_arguments { 2 } + +sub _inline_check_arguments { + my $self = shift; + + return $self->_inline_check_var_is_valid_index('$_[0]'); +} + +sub _adds_members { 1 } + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + return '(do { ' + . 'my @potential = @{ (' . $slot_access . ') }; ' + . '$potential[$_[0]] = $_[1]; ' + . '\@potential; ' + . '})'; +} + +# We need to override this because while @_ can be written to, we cannot write +# directly to $_[1]. +sub _inline_coerce_new_values { + my $self = shift; + + return unless $self->associated_attribute->should_coerce; + + return unless $self->_tc_member_type_can_coerce; + + return '@_ = ($_[0], $member_coercion->($_[1]));'; +}; + +sub _new_members { '$_[1]' } + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return $slot_access . '->[$_[0]] = $_[1];'; +} + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return $slot_access . '->[$_[0]]'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/shallow_clone.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/shallow_clone.pm new file mode 100644 index 0000000..f4dd6b4 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/shallow_clone.pm @@ -0,0 +1,26 @@ +package Moose::Meta::Method::Accessor::Native::Array::shallow_clone; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Params::Util (); + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader'; + +sub _minimum_arguments { 0 } + +sub _maximum_arguments { 0 } + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return '[ @{ (' . $slot_access . ') } ]'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/shift.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/shift.pm new file mode 100644 index 0000000..f0c3057 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/shift.pm @@ -0,0 +1,47 @@ +package Moose::Meta::Method::Accessor::Native::Array::shift; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Array::Writer'; + +sub _maximum_arguments { 0 } + +sub _adds_members { 0 } + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + return '[ @{ (' . $slot_access . ') } > 1 ' + . '? @{ (' . $slot_access . ') }[1..$#{ (' . $slot_access . ') }] ' + . ': () ]'; +} + +sub _inline_capture_return_value { + my $self = shift; + my ($slot_access) = @_; + + return 'my $old = ' . $slot_access . '->[0];'; +} + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return 'shift @{ (' . $slot_access . ') };'; +} + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return '$old'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/shuffle.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/shuffle.pm new file mode 100644 index 0000000..9e7a93e --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/shuffle.pm @@ -0,0 +1,24 @@ +package Moose::Meta::Method::Accessor::Native::Array::shuffle; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use List::Util (); + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader'; + +sub _maximum_arguments { 0 } + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return 'List::Util::shuffle @{ (' . $slot_access . ') }'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/sort.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/sort.pm new file mode 100644 index 0000000..a1b15a1 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/sort.pm @@ -0,0 +1,44 @@ +package Moose::Meta::Method::Accessor::Native::Array::sort; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Params::Util (); + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader'; + +sub _maximum_arguments { 1 } + +sub _inline_check_arguments { + my $self = shift; + + return ( + 'if (@_ && !Params::Util::_CODELIKE($_[0])) {', + $self->_inline_throw_exception( InvalidArgumentToMethod => + 'argument => $_[0],'. + 'method_name => "sort",'. + 'type_of_argument => "code reference",'. + 'type => "CodeRef",', + ) . ';', + '}', + ); +} + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return + 'wantarray ? ( ' . + '$_[0] ' + . '? sort { $_[0]->($a, $b) } @{ (' . $slot_access . ') } ' + . ': sort @{ (' . $slot_access . ') }' + . ' ) : @{ (' . $slot_access . ') }'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/sort_in_place.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/sort_in_place.pm new file mode 100644 index 0000000..cfdb2c1 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/sort_in_place.pm @@ -0,0 +1,45 @@ +package Moose::Meta::Method::Accessor::Native::Array::sort_in_place; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Params::Util (); + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Array::Writer'; + +sub _maximum_arguments { 1 } + +sub _inline_check_arguments { + my $self = shift; + + return ( + 'if (@_ && !Params::Util::_CODELIKE($_[0])) {', + $self->_inline_throw_exception( InvalidArgumentToMethod => + 'argument => $_[0],'. + 'method_name => "sort_in_place",'. + 'type_of_argument => "code reference",'. + 'type => "CodeRef",', + ) . ';', + '}', + ); +} + +sub _adds_members { 0 } + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + return '[ $_[0] ' + . '? sort { $_[0]->($a, $b) } @{ (' . $slot_access . ') } ' + . ': sort @{ (' . $slot_access . ') } ]'; +} + +sub _return_value { '' } + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/splice.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/splice.pm new file mode 100644 index 0000000..8bbc6df --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/splice.pm @@ -0,0 +1,72 @@ +package Moose::Meta::Method::Accessor::Native::Array::splice; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Array::Writer'; + +sub _minimum_arguments { 1 } + +sub _adds_members { 1 } + +sub _inline_process_arguments { + return ( + 'my $idx = shift;', + 'my $len = @_ ? shift : undef;', + ); +} + +sub _inline_check_arguments { + my $self = shift; + + return ( + $self->_inline_check_var_is_valid_index('$idx'), + 'if (defined($len) && $len !~ /^-?\d+$/) {', + $self->_inline_throw_exception( InvalidArgumentToMethod => + 'argument => $len,'. + 'method_name => "splice",'. + 'type_of_argument => "integer",'. + 'type => "Int",'. + 'argument_noun => "length argument"', + ) . ';', + '}', + ); +} + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + return '(do { ' + . 'my @potential = @{ (' . $slot_access . ') }; ' + . '@return = defined $len ' + . '? (splice @potential, $idx, $len, @_) ' + . ': (splice @potential, $idx); ' + . '\@potential;' + . '})'; +} + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return ( + '@return = defined $len', + '? (splice @{ (' . $slot_access . ') }, $idx, $len, @_)', + ': (splice @{ (' . $slot_access . ') }, $idx);', + ); +} + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return 'wantarray ? @return : $return[-1]'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/uniq.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/uniq.pm new file mode 100644 index 0000000..535b802 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/uniq.pm @@ -0,0 +1,24 @@ +package Moose::Meta::Method::Accessor::Native::Array::uniq; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use List::MoreUtils (); + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader'; + +sub _maximum_arguments { 0 } + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return 'List::MoreUtils::uniq @{ (' . $slot_access . ') }'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/unshift.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/unshift.pm new file mode 100644 index 0000000..4111671 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Array/unshift.pm @@ -0,0 +1,36 @@ +package Moose::Meta::Method::Accessor::Native::Array::unshift; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Array::Writer'; + +sub _adds_members { 1 } + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + return '[ @_, @{ (' . $slot_access . ') } ]'; +} + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return 'unshift @{ (' . $slot_access . ') }, @_;'; +} + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return 'scalar @{ (' . $slot_access . ') }'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Bool/not.pm b/lib/Moose/Meta/Method/Accessor/Native/Bool/not.pm new file mode 100644 index 0000000..60eb646 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Bool/not.pm @@ -0,0 +1,20 @@ +package Moose::Meta::Method::Accessor::Native::Bool::not; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader'; + +sub _maximum_arguments { 0 } + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return '!' . $slot_access; +} + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Bool/set.pm b/lib/Moose/Meta/Method/Accessor/Native/Bool/set.pm new file mode 100644 index 0000000..725da20 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Bool/set.pm @@ -0,0 +1,24 @@ +package Moose::Meta::Method::Accessor::Native::Bool::set; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Writer'; + +sub _maximum_arguments { 0 } + +sub _potential_value { 1 } + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return $slot_access . ' = 1;'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Bool/toggle.pm b/lib/Moose/Meta/Method/Accessor/Native/Bool/toggle.pm new file mode 100644 index 0000000..663b1a2 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Bool/toggle.pm @@ -0,0 +1,29 @@ +package Moose::Meta::Method::Accessor::Native::Bool::toggle; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Writer'; + +sub _maximum_arguments { 0 } + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + return $slot_access . ' ? 0 : 1'; +} + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return $slot_access . ' = ' . $slot_access . ' ? 0 : 1;'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Bool/unset.pm b/lib/Moose/Meta/Method/Accessor/Native/Bool/unset.pm new file mode 100644 index 0000000..6c5c62b --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Bool/unset.pm @@ -0,0 +1,24 @@ +package Moose::Meta::Method::Accessor::Native::Bool::unset; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Writer'; + +sub _maximum_arguments { 0 } + +sub _potential_value { 0 } + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return $slot_access . ' = 0;'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Code/execute.pm b/lib/Moose/Meta/Method/Accessor/Native/Code/execute.pm new file mode 100644 index 0000000..c74604f --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Code/execute.pm @@ -0,0 +1,20 @@ +package Moose::Meta::Method::Accessor::Native::Code::execute; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader'; + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return $slot_access . '->(@_)'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Code/execute_method.pm b/lib/Moose/Meta/Method/Accessor/Native/Code/execute_method.pm new file mode 100644 index 0000000..b3d40b9 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Code/execute_method.pm @@ -0,0 +1,20 @@ +package Moose::Meta::Method::Accessor::Native::Code::execute_method; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader'; + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return $slot_access . '->($self, @_)'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Collection.pm b/lib/Moose/Meta/Method/Accessor/Native/Collection.pm new file mode 100644 index 0000000..67331d5 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Collection.pm @@ -0,0 +1,167 @@ +package Moose::Meta::Method::Accessor::Native::Collection; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +requires qw( _adds_members ); + +sub _inline_coerce_new_values { + my $self = shift; + + return unless $self->associated_attribute->should_coerce; + + return unless $self->_tc_member_type_can_coerce; + + return ( + '(' . $self->_new_members . ') = map { $member_coercion->($_) }', + $self->_new_members . ';', + ); +} + +sub _tc_member_type_can_coerce { + my $self = shift; + + my $member_tc = $self->_tc_member_type; + + return $member_tc && $member_tc->has_coercion; +} + +sub _tc_member_type { + my $self = shift; + + my $tc = $self->associated_attribute->type_constraint; + while ($tc) { + return $tc->type_parameter + if $tc->can('type_parameter'); + $tc = $tc->parent; + } + + return; +} + +sub _writer_value_needs_copy { + my $self = shift; + + return $self->_constraint_must_be_checked + && !$self->_check_new_members_only; +} + +sub _inline_tc_code { + my $self = shift; + my ($value, $tc, $coercion, $message, $is_lazy) = @_; + + return unless $self->_constraint_must_be_checked; + + if ($self->_check_new_members_only) { + return unless $self->_adds_members; + + return $self->_inline_check_member_constraint($self->_new_members); + } + else { + return ( + $self->_inline_check_coercion($value, $tc, $coercion, $is_lazy), + $self->_inline_check_constraint($value, $tc, $message, $is_lazy), + ); + } +} + +sub _check_new_members_only { + my $self = shift; + + my $attr = $self->associated_attribute; + + my $tc = $attr->type_constraint; + + # If we have a coercion, we could come up with an entirely new value after + # coercing, so we need to check everything, + return 0 if $attr->should_coerce && $tc->has_coercion; + + # If the parent is our root type (ArrayRef, HashRef, etc), that means we + # can just check the new members of the collection, because we know that + # we will always be generating an appropriate collection type. + # + # However, if this type has its own constraint (it's Parameteriz_able_, + # not Paramet_erized_), we don't know what is being checked by the + # constraint, so we need to check the whole value, not just the members. + return 1 + if $self->_is_root_type( $tc->parent ) + && ( $tc->isa('Moose::Meta::TypeConstraint::Parameterized') + || $tc->isa('Specio::Constraint::Parameterized') ); + + return 0; +} + +sub _inline_check_member_constraint { + my $self = shift; + my ($new_value) = @_; + + my $attr_name = $self->associated_attribute->name; + + my $check + = $self->_tc_member_type->can_be_inlined + ? '! (' . $self->_tc_member_type->_inline_check('$new_val') . ')' + : ' !$member_tc->($new_val) '; + + return ( + 'for my $new_val (' . $new_value . ') {', + "if ($check) {", + 'my $msg = do { local $_ = $new_val; $member_message->($new_val) };'. + $self->_inline_throw_exception( ValidationFailedForInlineTypeConstraint => + "attribute_name => '".$attr_name."',". + 'type_constraint_message => $msg,'. + 'class_name => $class_name,'. + 'value => $new_val,'. + 'new_member => 1', + ) . ';', + '}', + '}', + ); +} + +sub _inline_get_old_value_for_trigger { + my $self = shift; + my ($instance, $old) = @_; + + my $attr = $self->associated_attribute; + return unless $attr->has_trigger; + + return ( + 'my ' . $old . ' = ' . $self->_has_value($instance), + '? ' . $self->_copy_old_value($self->_get_value($instance)), + ': ();', + ); +} + +around _eval_environment => sub { + my $orig = shift; + my $self = shift; + + my $env = $self->$orig(@_); + + my $member_tc = $self->_tc_member_type; + + return $env unless $member_tc; + + $env->{'$member_tc'} = \( $member_tc->_compiled_type_constraint ); + $env->{'$member_coercion'} = \( + $member_tc->coercion->_compiled_type_coercion + ) if $member_tc->has_coercion; + $env->{'$member_message'} = \( + $member_tc->has_message + ? $member_tc->message + : $member_tc->_default_message + ); + + my $tc_env = $member_tc->inline_environment(); + + $env = { %{$env}, %{$tc_env} }; + + return $env; +}; + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Counter/Writer.pm b/lib/Moose/Meta/Method/Accessor/Native/Counter/Writer.pm new file mode 100644 index 0000000..55ab4a7 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Counter/Writer.pm @@ -0,0 +1,24 @@ +package Moose::Meta::Method::Accessor::Native::Counter::Writer; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Writer'; + +sub _constraint_must_be_checked { + my $self = shift; + + my $attr = $self->associated_attribute; + + return $attr->has_type_constraint + && ($attr->type_constraint->name =~ /^(?:Num|Int)$/ + || ($attr->should_coerce && $attr->type_constraint->has_coercion) + ); +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Counter/dec.pm b/lib/Moose/Meta/Method/Accessor/Native/Counter/dec.pm new file mode 100644 index 0000000..3e61d59 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Counter/dec.pm @@ -0,0 +1,30 @@ +package Moose::Meta::Method::Accessor::Native::Counter::dec; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Writer'; + +sub _minimum_arguments { 0 } +sub _maximum_arguments { 1 } + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + return $slot_access . ' - (defined $_[0] ? $_[0] : 1)'; +} + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return $slot_access . ' -= defined $_[0] ? $_[0] : 1;'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Counter/inc.pm b/lib/Moose/Meta/Method/Accessor/Native/Counter/inc.pm new file mode 100644 index 0000000..1efeab8 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Counter/inc.pm @@ -0,0 +1,30 @@ +package Moose::Meta::Method::Accessor::Native::Counter::inc; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Writer'; + +sub _minimum_arguments { 0 } +sub _maximum_arguments { 1 } + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + return $slot_access . ' + (defined $_[0] ? $_[0] : 1)'; +} + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return $slot_access . ' += defined $_[0] ? $_[0] : 1;'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Counter/reset.pm b/lib/Moose/Meta/Method/Accessor/Native/Counter/reset.pm new file mode 100644 index 0000000..b62ac7b --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Counter/reset.pm @@ -0,0 +1,36 @@ +package Moose::Meta::Method::Accessor::Native::Counter::reset; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Writer'; + +sub _maximum_arguments { 0 } + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + my $attr = $self->associated_attribute; + + return '(do { ' + . join(' ', $attr->_inline_generate_default( + '$self', '$default_for_reset' + )) . ' ' + . '$default_for_reset; ' + . '})'; +} + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return $slot_access . ' = ' . $self->_potential_value . ';'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Counter/set.pm b/lib/Moose/Meta/Method/Accessor/Native/Counter/set.pm new file mode 100644 index 0000000..671984c --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Counter/set.pm @@ -0,0 +1,25 @@ +package Moose::Meta::Method::Accessor::Native::Counter::set; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Writer'; + +sub _minimum_arguments { 1 } +sub _maximum_arguments { 1 } + +sub _potential_value { '$_[0]' } + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return $slot_access . ' = $_[0];'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Hash.pm b/lib/Moose/Meta/Method/Accessor/Native/Hash.pm new file mode 100644 index 0000000..721c5f5 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Hash.pm @@ -0,0 +1,28 @@ +package Moose::Meta::Method::Accessor::Native::Hash; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +sub _inline_check_var_is_valid_key { + my $self = shift; + my ($var) = @_; + + return ( + 'if (!defined(' . $var . ')) {', + $self->_inline_throw_exception( InvalidArgumentToMethod => + 'argument => '.$var.','. + 'method_name => "'.$self->delegate_to_method.'",'. + 'type_of_argument => "defined value",'. + 'type => "Defined",'. + 'argument_noun => "key"', + ) . ';', + '}', + ); +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Hash/Writer.pm b/lib/Moose/Meta/Method/Accessor/Native/Hash/Writer.pm new file mode 100644 index 0000000..ccc3e1f --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Hash/Writer.pm @@ -0,0 +1,31 @@ +package Moose::Meta::Method::Accessor::Native::Hash::Writer; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Class::MOP::MiniTrait; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Writer', + 'Moose::Meta::Method::Accessor::Native::Hash', + 'Moose::Meta::Method::Accessor::Native::Collection'; + +sub _inline_coerce_new_values { + my $self = shift; + $self->Moose::Meta::Method::Accessor::Native::Collection::_inline_coerce_new_values(@_); +} + +sub _new_values { '@values' } + +sub _copy_old_value { + my $self = shift; + my ($slot_access) = @_; + + return '{ %{ (' . $slot_access . ') } }'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Hash/accessor.pm b/lib/Moose/Meta/Method/Accessor/Native/Hash/accessor.pm new file mode 100644 index 0000000..f4f978e --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Hash/accessor.pm @@ -0,0 +1,61 @@ +package Moose::Meta::Method::Accessor::Native::Hash::accessor; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Hash::set', + 'Moose::Meta::Method::Accessor::Native::Hash::get'; + +sub _inline_process_arguments { + my $self = shift; + $self->Moose::Meta::Method::Accessor::Native::Hash::set::_inline_process_arguments(@_); +} + +sub _inline_check_argument_count { + my $self = shift; + $self->Moose::Meta::Method::Accessor::Native::Hash::set::_inline_check_argument_count(@_); +} + +sub _inline_check_arguments { + my $self = shift; + $self->Moose::Meta::Method::Accessor::Native::Hash::set::_inline_check_arguments(@_); +} + +sub _return_value { + my $self = shift; + $self->Moose::Meta::Method::Accessor::Native::Hash::set::_return_value(@_); +} + +sub _generate_method { + my $self = shift; + + my $inv = '$self'; + my $slot_access = $self->_get_value($inv); + + return ( + 'sub {', + 'my ' . $inv . ' = shift;', + $self->_inline_curried_arguments, + $self->_inline_check_lazy($inv, '$type_constraint', '$type_coercion', '$type_message'), + # get + 'if (@_ == 1) {', + $self->_inline_check_var_is_valid_key('$_[0]'), + $slot_access . '->{$_[0]}', + '}', + # set + 'else {', + $self->_inline_writer_core($inv, $slot_access), + '}', + '}', + ); +} + +sub _minimum_arguments { 1 } +sub _maximum_arguments { 2 } + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Hash/clear.pm b/lib/Moose/Meta/Method/Accessor/Native/Hash/clear.pm new file mode 100644 index 0000000..751a443 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Hash/clear.pm @@ -0,0 +1,28 @@ +package Moose::Meta::Method::Accessor::Native::Hash::clear; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Hash::Writer'; + +sub _maximum_arguments { 0 } + +sub _adds_members { 0 } + +sub _potential_value { '{}' } + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return $slot_access . ' = {};'; +} + +sub _return_value { '' } + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Hash/count.pm b/lib/Moose/Meta/Method/Accessor/Native/Hash/count.pm new file mode 100644 index 0000000..aca9116 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Hash/count.pm @@ -0,0 +1,22 @@ +package Moose::Meta::Method::Accessor::Native::Hash::count; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader'; + +sub _maximum_arguments { 0 } + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return 'scalar keys %{ (' . $slot_access . ') }'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Hash/defined.pm b/lib/Moose/Meta/Method/Accessor/Native/Hash/defined.pm new file mode 100644 index 0000000..0062918 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Hash/defined.pm @@ -0,0 +1,31 @@ +package Moose::Meta::Method::Accessor::Native::Hash::defined; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader', + 'Moose::Meta::Method::Accessor::Native::Hash'; + +sub _minimum_arguments { 1 } + +sub _maximum_arguments { 1 } + +sub _inline_check_arguments { + my $self = shift; + + return $self->_inline_check_var_is_valid_key('$_[0]'); +} + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return 'defined ' . $slot_access . '->{ $_[0] }'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Hash/delete.pm b/lib/Moose/Meta/Method/Accessor/Native/Hash/delete.pm new file mode 100644 index 0000000..1a6d706 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Hash/delete.pm @@ -0,0 +1,40 @@ +package Moose::Meta::Method::Accessor::Native::Hash::delete; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Hash::Writer'; + +sub _adds_members { 0 } + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + return '(do { ' + . 'my %potential = %{ (' . $slot_access . ') }; ' + . '@return = delete @potential{@_}; ' + . '\%potential; ' + . '})'; +} + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return '@return = delete @{ (' . $slot_access . ') }{@_};'; +} + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return 'wantarray ? @return : $return[-1]'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Hash/elements.pm b/lib/Moose/Meta/Method/Accessor/Native/Hash/elements.pm new file mode 100644 index 0000000..d1ba09d --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Hash/elements.pm @@ -0,0 +1,23 @@ +package Moose::Meta::Method::Accessor::Native::Hash::elements; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader'; + +sub _maximum_arguments { 0 } + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return 'map { $_, ' . $slot_access . '->{$_} } ' + . 'keys %{ (' . $slot_access . ') }'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Hash/exists.pm b/lib/Moose/Meta/Method/Accessor/Native/Hash/exists.pm new file mode 100644 index 0000000..7ab09cc --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Hash/exists.pm @@ -0,0 +1,31 @@ +package Moose::Meta::Method::Accessor::Native::Hash::exists; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader', + 'Moose::Meta::Method::Accessor::Native::Hash'; + +sub _minimum_arguments { 1 } + +sub _maximum_arguments { 1 } + +sub _inline_check_arguments { + my $self = shift; + + return $self->_inline_check_var_is_valid_key('$_[0]'); +} + +sub _return_value { + my $self = shift; + my ($slot_access) = shift; + + return 'exists ' . $slot_access . '->{ $_[0] }'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Hash/get.pm b/lib/Moose/Meta/Method/Accessor/Native/Hash/get.pm new file mode 100644 index 0000000..a91c8f8 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Hash/get.pm @@ -0,0 +1,35 @@ +package Moose::Meta::Method::Accessor::Native::Hash::get; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader', + 'Moose::Meta::Method::Accessor::Native::Hash'; + +sub _minimum_arguments { 1 } + +sub _inline_check_arguments { + my $self = shift; + + return ( + 'for (@_) {', + $self->_inline_check_var_is_valid_key('$_'), + '}', + ); +} + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return '@_ > 1 ' + . '? @{ (' . $slot_access . ') }{@_} ' + . ': ' . $slot_access . '->{$_[0]}'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Hash/is_empty.pm b/lib/Moose/Meta/Method/Accessor/Native/Hash/is_empty.pm new file mode 100644 index 0000000..7948927 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Hash/is_empty.pm @@ -0,0 +1,22 @@ +package Moose::Meta::Method::Accessor::Native::Hash::is_empty; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader'; + +sub _maximum_arguments { 0 } + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return 'scalar keys %{ (' . $slot_access . ') } ? 0 : 1'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Hash/keys.pm b/lib/Moose/Meta/Method/Accessor/Native/Hash/keys.pm new file mode 100644 index 0000000..439be94 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Hash/keys.pm @@ -0,0 +1,22 @@ +package Moose::Meta::Method::Accessor::Native::Hash::keys; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader'; + +sub _maximum_arguments { 0 } + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return 'keys %{ (' . $slot_access . ') }'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Hash/kv.pm b/lib/Moose/Meta/Method/Accessor/Native/Hash/kv.pm new file mode 100644 index 0000000..4bbb325 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Hash/kv.pm @@ -0,0 +1,23 @@ +package Moose::Meta::Method::Accessor::Native::Hash::kv; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader'; + +sub _maximum_arguments { 0 } + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return 'map { [ $_, ' . $slot_access . '->{$_} ] } ' + . 'keys %{ (' . $slot_access . ') }'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Hash/set.pm b/lib/Moose/Meta/Method/Accessor/Native/Hash/set.pm new file mode 100644 index 0000000..7d7a1fa --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Hash/set.pm @@ -0,0 +1,103 @@ +package Moose::Meta::Method::Accessor::Native::Hash::set; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use List::MoreUtils (); +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Hash::Writer'; + +sub _minimum_arguments { 2 } + +sub _maximum_arguments { undef } + +around _inline_check_argument_count => sub { + my $orig = shift; + my $self = shift; + + return ( + $self->$orig(@_), + 'if (@_ % 2) {', + $self->_inline_throw_exception( MustPassEvenNumberOfArguments => + "method_name => '".$self->delegate_to_method."',". + 'args => \@_', + ) . ';', + '}', + ); +}; + +sub _inline_process_arguments { + my $self = shift; + + return ( + 'my @keys_idx = grep { ! ($_ % 2) } 0..$#_;', + 'my @values_idx = grep { $_ % 2 } 0..$#_;', + ); +} + +sub _inline_check_arguments { + my $self = shift; + + return ( + 'for (@keys_idx) {', + 'if (!defined($_[$_])) {', + $self->_inline_throw_exception( UndefinedHashKeysPassedToMethod => + 'hash_keys => \@keys_idx,'. + "method_name => '".$self->delegate_to_method."'", + ) . ';', + '}', + '}', + ); +} + +sub _adds_members { 1 } + +# We need to override this because while @_ can be written to, we cannot write +# directly to $_[1]. +sub _inline_coerce_new_values { + my $self = shift; + + return unless $self->associated_attribute->should_coerce; + + return unless $self->_tc_member_type_can_coerce; + + # Is there a simpler way to do this? + return ( + 'my $iter = List::MoreUtils::natatime(2, @_);', + '@_ = ();', + 'while (my ($key, $val) = $iter->()) {', + 'push @_, $key, $member_coercion->($val);', + '}', + ); +}; + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + return '{ %{ (' . $slot_access . ') }, @_ }'; +} + +sub _new_members { '@_[ @values_idx ]' } + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return '@{ (' . $slot_access . ') }{ @_[@keys_idx] } = @_[@values_idx];'; +} + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return 'wantarray ' + . '? @{ (' . $slot_access . ') }{ @_[@keys_idx] } ' + . ': ' . $slot_access . '->{ $_[$keys_idx[0]] }'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Hash/shallow_clone.pm b/lib/Moose/Meta/Method/Accessor/Native/Hash/shallow_clone.pm new file mode 100644 index 0000000..62b09cb --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Hash/shallow_clone.pm @@ -0,0 +1,26 @@ +package Moose::Meta::Method::Accessor::Native::Hash::shallow_clone; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Params::Util (); + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader'; + +sub _minimum_arguments { 0 } + +sub _maximum_arguments { 0 } + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return '{ %{ (' . $slot_access . ') } }'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Hash/values.pm b/lib/Moose/Meta/Method/Accessor/Native/Hash/values.pm new file mode 100644 index 0000000..750ce76 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Hash/values.pm @@ -0,0 +1,22 @@ +package Moose::Meta::Method::Accessor::Native::Hash::values; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader'; + +sub _maximum_arguments { 0 } + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return 'values %{ (' . $slot_access . ') }'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Number/abs.pm b/lib/Moose/Meta/Method/Accessor/Native/Number/abs.pm new file mode 100644 index 0000000..987a89f --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Number/abs.pm @@ -0,0 +1,29 @@ +package Moose::Meta::Method::Accessor::Native::Number::abs; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Writer'; + +sub _maximum_arguments { 0 } + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + return 'abs(' . $slot_access . ')'; +} + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return $slot_access . ' = abs(' . $slot_access . ');'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Number/add.pm b/lib/Moose/Meta/Method/Accessor/Native/Number/add.pm new file mode 100644 index 0000000..a7bd95c --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Number/add.pm @@ -0,0 +1,31 @@ +package Moose::Meta::Method::Accessor::Native::Number::add; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Writer'; + +sub _minimum_arguments { 1 } + +sub _maximum_arguments { 1 } + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + return $slot_access . ' + $_[0]'; +} + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return $slot_access . ' += $_[0];'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Number/div.pm b/lib/Moose/Meta/Method/Accessor/Native/Number/div.pm new file mode 100644 index 0000000..e2037a2 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Number/div.pm @@ -0,0 +1,31 @@ +package Moose::Meta::Method::Accessor::Native::Number::div; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Writer'; + +sub _minimum_arguments { 1 } + +sub _maximum_arguments { 1 } + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + return $slot_access . ' / $_[0]'; +} + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return $slot_access . ' /= $_[0];'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Number/mod.pm b/lib/Moose/Meta/Method/Accessor/Native/Number/mod.pm new file mode 100644 index 0000000..80a3c2a --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Number/mod.pm @@ -0,0 +1,31 @@ +package Moose::Meta::Method::Accessor::Native::Number::mod; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Writer'; + +sub _minimum_arguments { 1 } + +sub _maximum_arguments { 1 } + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + return $slot_access . ' % $_[0]'; +} + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return $slot_access . ' %= $_[0];'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Number/mul.pm b/lib/Moose/Meta/Method/Accessor/Native/Number/mul.pm new file mode 100644 index 0000000..6b019a6 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Number/mul.pm @@ -0,0 +1,31 @@ +package Moose::Meta::Method::Accessor::Native::Number::mul; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Writer'; + +sub _minimum_arguments { 1 } + +sub _maximum_arguments { 1 } + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + return $slot_access . ' * $_[0]'; +} + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return $slot_access . ' *= $_[0];'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Number/set.pm b/lib/Moose/Meta/Method/Accessor/Native/Number/set.pm new file mode 100644 index 0000000..2aa9c40 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Number/set.pm @@ -0,0 +1,25 @@ +package Moose::Meta::Method::Accessor::Native::Number::set; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Writer'; + +sub _minimum_arguments { 1 } +sub _maximum_arguments { 1 } + +sub _potential_value { '$_[0]' } + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return $slot_access . ' = $_[0];'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Number/sub.pm b/lib/Moose/Meta/Method/Accessor/Native/Number/sub.pm new file mode 100644 index 0000000..c2fa157 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Number/sub.pm @@ -0,0 +1,31 @@ +package Moose::Meta::Method::Accessor::Native::Number::sub; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Writer'; + +sub _minimum_arguments { 1 } + +sub _maximum_arguments { 1 } + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + return $slot_access . ' - $_[0]'; +} + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return $slot_access . ' -= $_[0];'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Reader.pm b/lib/Moose/Meta/Method/Accessor/Native/Reader.pm new file mode 100644 index 0000000..df885e5 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Reader.pm @@ -0,0 +1,47 @@ +package Moose::Meta::Method::Accessor::Native::Reader; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native'; + +requires '_return_value'; + +sub _generate_method { + my $self = shift; + + my $inv = '$self'; + my $slot_access = $self->_get_value($inv); + + return ( + 'sub {', + 'my ' . $inv . ' = shift;', + $self->_inline_curried_arguments, + $self->_inline_reader_core($inv, $slot_access, @_), + '}', + ); +} + +sub _inline_reader_core { + my $self = shift; + my ($inv, $slot_access, @extra) = @_; + + return ( + $self->_inline_check_argument_count, + $self->_inline_process_arguments($inv, $slot_access), + $self->_inline_check_arguments, + $self->_inline_check_lazy($inv, '$type_constraint', '$type_coercion', '$type_message'), + $self->_inline_return_value($slot_access), + ); +} + +sub _inline_process_arguments { return } + +sub _inline_check_arguments { return } + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/String/append.pm b/lib/Moose/Meta/Method/Accessor/Native/String/append.pm new file mode 100644 index 0000000..e941e5a --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/String/append.pm @@ -0,0 +1,31 @@ +package Moose::Meta::Method::Accessor::Native::String::append; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Writer'; + +sub _minimum_arguments { 1 } + +sub _maximum_arguments { 1 } + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + return '( ' . $slot_access . ' . $_[0] )'; +} + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return $slot_access . ' .= $_[0];'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/String/chomp.pm b/lib/Moose/Meta/Method/Accessor/Native/String/chomp.pm new file mode 100644 index 0000000..49e2215 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/String/chomp.pm @@ -0,0 +1,40 @@ +package Moose::Meta::Method::Accessor::Native::String::chomp; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Writer'; + +sub _maximum_arguments { 0 } + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + return '(do { ' + . 'my $val = ' . $slot_access . '; ' + . '@return = chomp $val; ' + . '$val ' + . '})'; +} + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return '@return = chomp ' . $slot_access . ';'; +} + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return '$return[0]'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/String/chop.pm b/lib/Moose/Meta/Method/Accessor/Native/String/chop.pm new file mode 100644 index 0000000..c15fd0f --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/String/chop.pm @@ -0,0 +1,40 @@ +package Moose::Meta::Method::Accessor::Native::String::chop; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Writer'; + +sub _maximum_arguments { 0 } + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + return '(do { ' + . 'my $val = ' . $slot_access . '; ' + . '@return = chop $val; ' + . '$val; ' + . '})'; +} + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return '@return = chop ' . $slot_access . ';'; +} + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return '$return[0]'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/String/clear.pm b/lib/Moose/Meta/Method/Accessor/Native/String/clear.pm new file mode 100644 index 0000000..7aec2c5 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/String/clear.pm @@ -0,0 +1,24 @@ +package Moose::Meta::Method::Accessor::Native::String::clear; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Writer'; + +sub _maximum_arguments { 0 } + +sub _potential_value { '""' } + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return $slot_access . ' = "";'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/String/inc.pm b/lib/Moose/Meta/Method/Accessor/Native/String/inc.pm new file mode 100644 index 0000000..3ee5605 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/String/inc.pm @@ -0,0 +1,33 @@ +package Moose::Meta::Method::Accessor::Native::String::inc; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Writer'; + +sub _maximum_arguments { 0 } + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + return '(do { ' + . 'my $val = ' . $slot_access . '; ' + . '$val++; ' + . '$val; ' + . '})'; +} + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return $slot_access . '++;'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/String/length.pm b/lib/Moose/Meta/Method/Accessor/Native/String/length.pm new file mode 100644 index 0000000..bf40b40 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/String/length.pm @@ -0,0 +1,22 @@ +package Moose::Meta::Method::Accessor::Native::String::length; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader'; + +sub _maximum_arguments { 0 } + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return 'length ' . $slot_access; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/String/match.pm b/lib/Moose/Meta/Method/Accessor/Native/String/match.pm new file mode 100644 index 0000000..ae85a96 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/String/match.pm @@ -0,0 +1,42 @@ +package Moose::Meta::Method::Accessor::Native::String::match; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Util (); +use Params::Util (); + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader'; + +sub _minimum_arguments { 1 } + +sub _maximum_arguments { 1 } + +sub _inline_check_arguments { + my $self = shift; + + return ( + 'if (!Moose::Util::_STRINGLIKE0($_[0]) && !Params::Util::_REGEX($_[0])) {', + $self->_inline_throw_exception( InvalidArgumentToMethod => + 'argument => $_[0],'. + 'type => "Str|RegexpRef",'. + 'type_of_argument => "string or regexp reference",'. + 'method_name => "match"', + ) . ';', + '}', + ); +} + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return $slot_access . ' =~ $_[0]'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/String/prepend.pm b/lib/Moose/Meta/Method/Accessor/Native/String/prepend.pm new file mode 100644 index 0000000..87a0695 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/String/prepend.pm @@ -0,0 +1,31 @@ +package Moose::Meta::Method::Accessor::Native::String::prepend; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Writer'; + +sub _minimum_arguments { 1 } + +sub _maximum_arguments { 1 } + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + return '$_[0] . ' . $slot_access; +} + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return $slot_access . ' = $_[0] . ' . $slot_access . ';'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/String/replace.pm b/lib/Moose/Meta/Method/Accessor/Native/String/replace.pm new file mode 100644 index 0000000..6e33609 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/String/replace.pm @@ -0,0 +1,69 @@ +package Moose::Meta::Method::Accessor::Native::String::replace; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Util (); +use Params::Util (); + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Writer'; + +sub _minimum_arguments { 1 } + +sub _maximum_arguments { 2 } + +sub _inline_check_arguments { + my $self = shift; + + return ( + 'if (!Moose::Util::_STRINGLIKE0($_[0]) && !Params::Util::_REGEX($_[0])) {', + $self->_inline_throw_exception( InvalidArgumentToMethod => + 'argument => $_[0],'. + 'method_name => "replace",'. + 'ordinal => "first",'. + 'type_of_argument => "string or regexp reference",'. + 'type => "Str|RegexpRef"', + ) . ';', + '}', + 'if (!Moose::Util::_STRINGLIKE0($_[1]) && !Params::Util::_CODELIKE($_[1])) {', + $self->_inline_throw_exception( InvalidArgumentToMethod => + 'argument => $_[1],'. + 'method_name => "replace",'. + 'ordinal => "second",'. + 'type_of_argument => "string or code reference",'. + 'type => "Str|CodeRef"', + ) . ';', + '}', + ); +} + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + return '(do { ' + . 'my $val = ' . $slot_access . '; ' + . 'ref $_[1] ' + . '? $val =~ s/$_[0]/$_[1]->()/e ' + . ': $val =~ s/$_[0]/$_[1]/; ' + . '$val; ' + . '})'; +} + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return ( + 'ref $_[1]', + '? ' . $slot_access . ' =~ s/$_[0]/$_[1]->()/e', + ': ' . $slot_access . ' =~ s/$_[0]/$_[1]/;', + ); +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/String/substr.pm b/lib/Moose/Meta/Method/Accessor/Native/String/substr.pm new file mode 100644 index 0000000..df82e23 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/String/substr.pm @@ -0,0 +1,123 @@ +package Moose::Meta::Method::Accessor::Native::String::substr; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Util (); + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native::Reader', + 'Moose::Meta::Method::Accessor::Native::Writer'; + +sub _generate_method { + my $self = shift; + + my $inv = '$self'; + my $slot_access = $self->_get_value($inv); + + return ( + 'sub {', + 'my ' . $inv . ' = shift;', + $self->_inline_curried_arguments, + 'if (@_ == 1 || @_ == 2) {', + $self->_inline_reader_core($inv, $slot_access), + '}', + 'elsif (@_ == 3) {', + $self->_inline_writer_core($inv, $slot_access), + '}', + 'else {', + $self->_inline_check_argument_count, + '}', + '}', + ); +} + +sub _minimum_arguments { 1 } +sub _maximum_arguments { 3 } + +sub _inline_process_arguments { + my $self = shift; + my ($inv, $slot_access) = @_; + + return ( + 'my $offset = shift;', + 'my $length = @_ ? shift : length ' . $slot_access . ';', + 'my $replacement = shift;', + ); +} + +sub _inline_check_arguments { + my $self = shift; + my ($for_writer) = @_; + + my @code = ( + 'if ($offset !~ /^-?\d+$/) {', + $self->_inline_throw_exception( InvalidArgumentToMethod => + 'argument => $offset,'. + 'ordinal => "first",'. + 'type_of_argument => "integer",'. + 'method_name => "substr",'. + 'type => "Int"', + ) . ';', + '}', + 'if ($length !~ /^-?\d+$/) {', + $self->_inline_throw_exception( InvalidArgumentToMethod => + 'argument => $length,'. + 'ordinal => "second",'. + 'type_of_argument => "integer",'. + 'method_name => "substr",'. + 'type => "Int"', + ) . ';', + '}', + ); + + if ($for_writer) { + push @code, ( + 'if (!Moose::Util::_STRINGLIKE0($replacement)) {', + $self->_inline_throw_exception( InvalidArgumentToMethod => + 'argument => $replacement,'. + 'ordinal => "third",'. + 'type_of_argument => "string",'. + 'method_name => "substr",'. + 'type => "Str"', + ) . ';', + '}', + ); + } + + return @code; +} + +sub _potential_value { + my $self = shift; + my ($slot_access) = @_; + + return '(do { ' + . 'my $potential = ' . $slot_access . '; ' + . '@return = substr $potential, $offset, $length, $replacement; ' + . '$potential; ' + . '})'; +} + +sub _inline_optimized_set_new_value { + my $self = shift; + my ($inv, $new, $slot_access) = @_; + + return '@return = substr ' . $slot_access . ', ' + . '$offset, $length, $replacement;'; +} + +sub _return_value { + my $self = shift; + my ($slot_access, $for_writer) = @_; + + return '$return[0]' if $for_writer; + + return 'substr ' . $slot_access . ', $offset, $length'; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Accessor/Native/Writer.pm b/lib/Moose/Meta/Method/Accessor/Native/Writer.pm new file mode 100644 index 0000000..b25e063 --- /dev/null +++ b/lib/Moose/Meta/Method/Accessor/Native/Writer.pm @@ -0,0 +1,174 @@ +package Moose::Meta::Method::Accessor::Native::Writer; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use List::Util 1.33 qw( any ); +use Moose::Util; + +use Moose::Role; + +with 'Moose::Meta::Method::Accessor::Native'; + +requires '_potential_value'; + +sub _generate_method { + my $self = shift; + + my $inv = '$self'; + my $slot_access = $self->_get_value($inv); + + return ( + 'sub {', + 'my ' . $inv . ' = shift;', + $self->_inline_curried_arguments, + $self->_inline_writer_core($inv, $slot_access), + '}', + ); +} + +sub _inline_writer_core { + my $self = shift; + my ($inv, $slot_access) = @_; + + my $potential = $self->_potential_value($slot_access); + my $old = '@old'; + + my @code; + push @code, ( + $self->_inline_check_argument_count, + $self->_inline_process_arguments($inv, $slot_access), + $self->_inline_check_arguments('for writer'), + $self->_inline_check_lazy($inv, '$type_constraint', '$type_coercion', '$type_message'), + ); + + if ($self->_return_value($slot_access)) { + # some writers will save the return value in this variable when they + # generate the potential value. + push @code, 'my @return;' + } + + push @code, ( + $self->_inline_coerce_new_values, + $self->_inline_copy_native_value(\$potential), + $self->_inline_tc_code($potential, '$type_constraint', '$type_coercion', '$type_message'), + $self->_inline_get_old_value_for_trigger($inv, $old), + $self->_inline_capture_return_value($slot_access), + $self->_inline_set_new_value($inv, $potential, $slot_access), + $self->_inline_trigger($inv, $slot_access, $old), + $self->_inline_return_value($slot_access, 'for writer'), + ); + + return @code; +} + +sub _inline_process_arguments { return } + +sub _inline_check_arguments { return } + +sub _inline_coerce_new_values { return } + +sub _writer_value_needs_copy { + my $self = shift; + + return $self->_constraint_must_be_checked; +} + +sub _constraint_must_be_checked { + my $self = shift; + + my $attr = $self->associated_attribute; + + return $attr->has_type_constraint + && ( !$self->_is_root_type( $attr->type_constraint ) + || ( $attr->should_coerce && $attr->type_constraint->has_coercion ) ); +} + +sub _is_root_type { + my $self = shift; + my $type = shift; + + if ( blessed($type) + && $type->can('does') + && $type->does('Specio::Constraint::Role::Interface') ) + { + require Specio::Library::Builtins; + return + any { $type->is_same_type_as( Specio::Library::Builtins::t($_) ) } + @{ $self->root_types }; + } + else { + my $name = $type->name; + return any { $name eq $_ } @{ $self->root_types }; + } +} + +sub _inline_copy_native_value { + my $self = shift; + my ($potential_ref) = @_; + + return unless $self->_writer_value_needs_copy; + + my $code = 'my $potential = ' . ${$potential_ref} . ';'; + + ${$potential_ref} = '$potential'; + + return $code; +} + +around _inline_tc_code => sub { + my $orig = shift; + my $self = shift; + my ($value, $tc, $coercion, $message, $for_lazy) = @_; + + return unless $for_lazy || $self->_constraint_must_be_checked; + + return $self->$orig(@_); +}; + +around _inline_check_constraint => sub { + my $orig = shift; + my $self = shift; + my ($value, $tc, $message, $for_lazy) = @_; + + return unless $for_lazy || $self->_constraint_must_be_checked; + + return $self->$orig(@_); +}; + +sub _inline_capture_return_value { return } + +sub _inline_set_new_value { + my $self = shift; + + return $self->_inline_store_value(@_) + if $self->_writer_value_needs_copy + || !$self->_slot_access_can_be_inlined + || !$self->_get_is_lvalue; + + return $self->_inline_optimized_set_new_value(@_); +} + +sub _get_is_lvalue { + my $self = shift; + + return $self->associated_attribute->associated_class->instance_metaclass->inline_get_is_lvalue; +} + +sub _inline_optimized_set_new_value { + my $self = shift; + + return $self->_inline_store_value(@_); +} + +sub _return_value { + my $self = shift; + my ($slot_access) = @_; + + return $slot_access; +} + +no Moose::Role; + +1; diff --git a/lib/Moose/Meta/Method/Augmented.pm b/lib/Moose/Meta/Method/Augmented.pm new file mode 100644 index 0000000..56a07d1 --- /dev/null +++ b/lib/Moose/Meta/Method/Augmented.pm @@ -0,0 +1,175 @@ +package Moose::Meta::Method::Augmented; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use parent 'Moose::Meta::Method'; + +use Moose::Util 'throw_exception'; + +sub new { + my ( $class, %args ) = @_; + + # the package can be overridden by roles + # it is really more like body's compilation stash + # this is where we need to override the definition of super() so that the + # body of the code can call the right overridden version + my $name = $args{name}; + my $meta = $args{class}; + + my $super = $meta->find_next_method_by_name($name); + + (defined $super) + || throw_exception( CannotAugmentNoSuperMethod => params => \%args, + class => $class, + method_name => $name + ); + + my $_super_package = $super->package_name; + # BUT!,... if this is an overridden method .... + if ($super->isa('Moose::Meta::Method::Overridden')) { + # we need to be sure that we actually + # find the next method, which is not + # an 'override' method, the reason is + # that an 'override' method will not + # be the one calling inner() + my $real_super = $meta->_find_next_method_by_name_which_is_not_overridden($name); + $_super_package = $real_super->package_name; + } + + my $super_body = $super->body; + + my $method = $args{method}; + + my $body = sub { + local $Moose::INNER_ARGS{$_super_package} = [ @_ ]; + local $Moose::INNER_BODY{$_super_package} = $method; + $super_body->(@_); + }; + + # FIXME store additional attrs + $class->wrap( + $body, + package_name => $meta->name, + name => $name + ); +} + +1; + +# ABSTRACT: A Moose Method metaclass for augmented methods + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Method::Augmented - A Moose Method metaclass for augmented methods + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class implements method augmentation logic for the L<Moose> +C<augment> keyword. + +The augmentation subroutine reference will be invoked explicitly using +the C<inner> keyword from the parent class's method definition. + +=head1 INHERITANCE + +C<Moose::Meta::Method::Augmented> is a subclass of L<Moose::Meta::Method>. + +=head1 METHODS + +=over 4 + +=item B<< Moose::Meta::Method::Augmented->new(%options) >> + +This constructs a new object. It accepts the following options: + +=over 8 + +=item * class + +The metaclass object for the class in which the augmentation is being +declared. This option is required. + +=item * name + +The name of the method which we are augmenting. This method must exist +in one of the class's superclasses. This option is required. + +=item * method + +The subroutine reference which implements the augmentation. This +option is required. + +=back + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Method/Constructor.pm b/lib/Moose/Meta/Method/Constructor.pm new file mode 100644 index 0000000..c6aaebb --- /dev/null +++ b/lib/Moose/Meta/Method/Constructor.pm @@ -0,0 +1,145 @@ +package Moose::Meta::Method::Constructor; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Scalar::Util 'weaken'; + +use parent 'Moose::Meta::Method', + 'Class::MOP::Method::Constructor'; + +use Moose::Util 'throw_exception'; + +sub new { + my $class = shift; + my %options = @_; + + my $meta = $options{metaclass}; + + (ref $options{options} eq 'HASH') + || throw_exception( MustPassAHashOfOptions => params => \%options, + class => $class + ); + + ($options{package_name} && $options{name}) + || throw_exception( MustSupplyPackageNameAndName => params => \%options, + class => $class + ); + + my $self = bless { + 'body' => undef, + 'package_name' => $options{package_name}, + 'name' => $options{name}, + 'options' => $options{options}, + 'associated_metaclass' => $meta, + 'definition_context' => $options{definition_context}, + '_expected_method_class' => $options{_expected_method_class} || 'Moose::Object', + } => $class; + + # we don't want this creating + # a cycle in the code, if not + # needed + weaken($self->{'associated_metaclass'}); + + $self->_initialize_body; + + return $self; +} + +## method + +sub _initialize_body { + my $self = shift; + $self->{'body'} = $self->_generate_constructor_method_inline; +} + +1; + +# ABSTRACT: Method Meta Object for constructors + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Method::Constructor - Method Meta Object for constructors + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class is a subclass of L<Class::MOP::Method::Constructor> that +provides additional Moose-specific functionality + +To understand this class, you should read the the +L<Class::MOP::Method::Constructor> documentation as well. + +=head1 INHERITANCE + +C<Moose::Meta::Method::Constructor> is a subclass of +L<Moose::Meta::Method> I<and> L<Class::MOP::Method::Constructor>. + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Method/Delegation.pm b/lib/Moose/Meta/Method/Delegation.pm new file mode 100644 index 0000000..752bd27 --- /dev/null +++ b/lib/Moose/Meta/Method/Delegation.pm @@ -0,0 +1,258 @@ +package Moose::Meta::Method::Delegation; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Scalar::Util 'blessed', 'weaken'; + +use parent 'Moose::Meta::Method', + 'Class::MOP::Method::Generated'; + +use Moose::Util 'throw_exception'; + +sub new { + my $class = shift; + my %options = @_; + + ( exists $options{attribute} ) + || throw_exception( MustSupplyAnAttributeToConstructWith => params => \%options, + class => $class + ); + + ( blessed( $options{attribute} ) + && $options{attribute}->isa('Moose::Meta::Attribute') ) + || throw_exception( MustSupplyAMooseMetaAttributeInstance => params => \%options, + class => $class + ); + + ( $options{package_name} && $options{name} ) + || throw_exception( MustSupplyPackageNameAndName => params => \%options, + class => $class + ); + + ( $options{delegate_to_method} && ( !ref $options{delegate_to_method} ) + || ( 'CODE' eq ref $options{delegate_to_method} ) ) + || throw_exception( MustSupplyADelegateToMethod => params => \%options, + class => $class + ); + + exists $options{curried_arguments} + || ( $options{curried_arguments} = [] ); + + ( $options{curried_arguments} && + ( 'ARRAY' eq ref $options{curried_arguments} ) ) + || throw_exception( MustSupplyArrayRefAsCurriedArguments => params => \%options, + class_name => $class + ); + + my $self = $class->_new( \%options ); + + weaken( $self->{'attribute'} ); + + $self->_initialize_body; + + return $self; +} + +sub _new { + my $class = shift; + my $options = @_ == 1 ? $_[0] : {@_}; + + return bless $options, $class; +} + +sub curried_arguments { (shift)->{'curried_arguments'} } + +sub associated_attribute { (shift)->{'attribute'} } + +sub delegate_to_method { (shift)->{'delegate_to_method'} } + +sub _initialize_body { + my $self = shift; + + my $method_to_call = $self->delegate_to_method; + return $self->{body} = $method_to_call + if ref $method_to_call; + + my $accessor = $self->_get_delegate_accessor; + + my $handle_name = $self->name; + + # NOTE: we used to do a goto here, but the goto didn't handle + # failure correctly (it just returned nothing), so I took that + # out. However, the more I thought about it, the less I liked it + # doing the goto, and I preferred the act of delegation being + # actually represented in the stack trace. - SL + # not inlining this, since it won't really speed things up at + # all... the only thing that would end up different would be + # interpolating in $method_to_call, and a bunch of things in the + # error handling that mostly never gets called - doy + $self->{body} = sub { + my $instance = shift; + my $proxy = $instance->$accessor(); + + if( !defined $proxy ) { + throw_exception( AttributeValueIsNotDefined => method => $self, + instance => $instance, + attribute => $self->associated_attribute, + ); + } + elsif( ref($proxy) && !blessed($proxy) ) { + throw_exception( AttributeValueIsNotAnObject => method => $self, + instance => $instance, + attribute => $self->associated_attribute, + given_value => $proxy + ); + } + + unshift @_, @{ $self->curried_arguments }; + $proxy->$method_to_call(@_); + }; +} + +sub _get_delegate_accessor { + my $self = shift; + my $attr = $self->associated_attribute; + + # NOTE: + # always use a named method when + # possible, if you use the method + # ref and there are modifiers on + # the accessors then it will not + # pick up the modifiers too. Only + # the named method will assure that + # we also have any modifiers run. + # - SL + my $accessor = $attr->has_read_method + ? $attr->get_read_method + : $attr->get_read_method_ref; + + $accessor = $accessor->body if Scalar::Util::blessed $accessor; + + return $accessor; +} + +1; + +# ABSTRACT: A Moose Method metaclass for delegation methods + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Method::Delegation - A Moose Method metaclass for delegation methods + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This is a subclass of L<Moose::Meta::Method> for delegation +methods. + +=head1 METHODS + +=over 4 + +=item B<< Moose::Meta::Method::Delegation->new(%options) >> + +This creates the delegation methods based on the provided C<%options>. + +=over 4 + +=item I<attribute> + +This must be an instance of C<Moose::Meta::Attribute> which this +accessor is being generated for. This options is B<required>. + +=item I<delegate_to_method> + +The method in the associated attribute's value to which we +delegate. This can be either a method name or a code reference. + +=item I<curried_arguments> + +An array reference of arguments that will be prepended to the argument list for +any call to the delegating method. + +=back + +=item B<< $metamethod->associated_attribute >> + +Returns the attribute associated with this method. + +=item B<< $metamethod->curried_arguments >> + +Return any curried arguments that will be passed to the delegated method. + +=item B<< $metamethod->delegate_to_method >> + +Returns the method to which this method delegates, as passed to the +constructor. + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Method/Destructor.pm b/lib/Moose/Meta/Method/Destructor.pm new file mode 100644 index 0000000..cd37245 --- /dev/null +++ b/lib/Moose/Meta/Method/Destructor.pm @@ -0,0 +1,255 @@ +package Moose::Meta::Method::Destructor; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Devel::GlobalDestruction (); +use Scalar::Util 'blessed', 'weaken'; +use Try::Tiny; + +use parent 'Moose::Meta::Method', + 'Class::MOP::Method::Inlined'; + +use Moose::Util 'throw_exception'; + +sub new { + my $class = shift; + my %options = @_; + + (ref $options{options} eq 'HASH') + || throw_exception( MustPassAHashOfOptions => params => \%options, + class => $class + ); + + ($options{package_name} && $options{name}) + || throw_exception( MustSupplyPackageNameAndName => params => \%options, + class => $class + ); + + my $self = bless { + # from our superclass + 'body' => undef, + 'package_name' => $options{package_name}, + 'name' => $options{name}, + # ... + 'options' => $options{options}, + 'definition_context' => $options{definition_context}, + 'associated_metaclass' => $options{metaclass}, + } => $class; + + # we don't want this creating + # a cycle in the code, if not + # needed + weaken($self->{'associated_metaclass'}); + + $self->_initialize_body; + + return $self; +} + +## accessors + +sub options { (shift)->{'options'} } + +## method + +sub is_needed { + my $self = shift; + my $metaclass = shift; + + ( blessed $metaclass && $metaclass->isa('Class::MOP::Class') ) + || throw_exception( MethodExpectedAMetaclassObject => metaclass => $metaclass, + class => $self + ); + + return $metaclass->find_method_by_name("DEMOLISHALL"); +} + +sub _initialize_body { + my $self = shift; + # TODO: + # the %options should also include a both + # a call 'initializer' and call 'SUPER::' + # options, which should cover approx 90% + # of the possible use cases (even if it + # requires some adaption on the part of + # the author, after all, nothing is free) + + my $class = $self->associated_metaclass->name; + my @source = ( + 'sub {', + 'my $self = shift;', + 'return ' . $self->_generate_fallback_destructor('$self'), + 'if Scalar::Util::blessed($self) ne \'' . $class . '\';', + $self->_generate_DEMOLISHALL('$self'), + 'return;', + '}', + ); + warn join("\n", @source) if $self->options->{debug}; + + my $code = try { + $self->_compile_code(source => \@source); + } + catch { + my $source = join("\n", @source); + throw_exception( CouldNotEvalDestructor => method_destructor_object => $self, + source => $source, + error => $_ + ); + }; + + $self->{'body'} = $code; +} + +sub _generate_fallback_destructor { + my $self = shift; + my ($inv) = @_; + + return $inv . '->Moose::Object::DESTROY(@_)'; +} + +sub _generate_DEMOLISHALL { + my $self = shift; + my ($inv) = @_; + + my @methods = $self->associated_metaclass->find_all_methods_by_name('DEMOLISH'); + return unless @methods; + + return ( + 'local $?;', + 'my $igd = Devel::GlobalDestruction::in_global_destruction;', + 'Try::Tiny::try {', + (map { $inv . '->' . $_->{class} . '::DEMOLISH($igd);' } @methods), + '}', + 'Try::Tiny::catch {', + 'die $_;', + '};', + ); +} + + +1; + +# ABSTRACT: Method Meta Object for destructors + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Method::Destructor - Method Meta Object for destructors + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class is a subclass of L<Class::MOP::Method::Inlined> that +provides Moose-specific functionality for inlining destructors. + +To understand this class, you should read the +L<Class::MOP::Method::Inlined> documentation as well. + +=head1 INHERITANCE + +C<Moose::Meta::Method::Destructor> is a subclass of +L<Moose::Meta::Method> I<and> L<Class::MOP::Method::Inlined>. + +=head1 METHODS + +=over 4 + +=item B<< Moose::Meta::Method::Destructor->new(%options) >> + +This constructs a new object. It accepts the following options: + +=over 8 + +=item * package_name + +The package for the class in which the destructor is being +inlined. This option is required. + +=item * name + +The name of the destructor method. This option is required. + +=item * metaclass + +The metaclass for the class this destructor belongs to. This is +optional, as it can be set later by calling C<< +$metamethod->attach_to_class >>. + +=back + +=item B<< Moose::Meta;:Method::Destructor->is_needed($metaclass) >> + +Given a L<Moose::Meta::Class> object, this method returns a boolean +indicating whether the class needs a destructor. If the class or any +of its parents defines a C<DEMOLISH> method, it needs a destructor. + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Method/Meta.pm b/lib/Moose/Meta/Method/Meta.pm new file mode 100644 index 0000000..7796683 --- /dev/null +++ b/lib/Moose/Meta/Method/Meta.pm @@ -0,0 +1,112 @@ +package Moose::Meta::Method::Meta; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use parent 'Moose::Meta::Method', + 'Class::MOP::Method::Meta'; + +sub _is_caller_mop_internal { + my $self = shift; + my ($caller) = @_; + return 1 if $caller =~ /^Moose(?:::|$)/; + return $self->SUPER::_is_caller_mop_internal($caller); +} + +# XXX: ugh multiple inheritance +sub wrap { + my $class = shift; + return $class->Class::MOP::Method::Meta::wrap(@_); +} + +sub _make_compatible_with { + my $self = shift; + return $self->Class::MOP::Method::Meta::_make_compatible_with(@_); +} + +1; + +# ABSTRACT: A Moose Method metaclass for C<meta> methods + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Method::Meta - A Moose Method metaclass for C<meta> methods + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class is a subclass of L<Class::MOP::Method::Meta> that +provides additional Moose-specific functionality, all of which is +private. + +To understand this class, you should read the the +L<Class::MOP::Method::Meta> documentation. + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Method/Overridden.pm b/lib/Moose/Meta/Method/Overridden.pm new file mode 100644 index 0000000..4c9aee7 --- /dev/null +++ b/lib/Moose/Meta/Method/Overridden.pm @@ -0,0 +1,164 @@ +package Moose::Meta::Method::Overridden; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use parent 'Moose::Meta::Method'; + +use Moose::Util 'throw_exception'; + +sub new { + my ( $class, %args ) = @_; + + # the package can be overridden by roles + # it is really more like body's compilation stash + # this is where we need to override the definition of super() so that the + # body of the code can call the right overridden version + my $super_package = $args{package} || $args{class}->name; + + my $name = $args{name}; + + my $super = $args{class}->find_next_method_by_name($name); + + (defined $super) + || throw_exception( CannotOverrideNoSuperMethod => class => $class, + params => \%args, + method_name => $name + ); + + my $super_body = $super->body; + + my $method = $args{method}; + + my $body = sub { + local $Moose::SUPER_PACKAGE = $super_package; + local @Moose::SUPER_ARGS = @_; + local $Moose::SUPER_BODY = $super_body; + return $method->(@_); + }; + + # FIXME do we need this make sure this works for next::method? + # subname "${super_package}::${name}", $method; + + # FIXME store additional attrs + $class->wrap( + $body, + package_name => $args{class}->name, + name => $name + ); +} + +1; + +# ABSTRACT: A Moose Method metaclass for overridden methods + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Method::Overridden - A Moose Method metaclass for overridden methods + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class implements method overriding logic for the L<Moose> +C<override> keyword. + +The overriding subroutine's parent will be invoked explicitly using +the C<super> keyword from the parent class's method definition. + +=head1 METHODS + +=over 4 + +=item B<< Moose::Meta::Method::Overridden->new(%options) >> + +This constructs a new object. It accepts the following options: + +=over 8 + +=item * class + +The metaclass object for the class in which the override is being +declared. This option is required. + +=item * name + +The name of the method which we are overriding. This method must exist +in one of the class's superclasses. This option is required. + +=item * method + +The subroutine reference which implements the overriding. This option +is required. + +=back + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Mixin/AttributeCore.pm b/lib/Moose/Meta/Mixin/AttributeCore.pm new file mode 100644 index 0000000..8503d8f --- /dev/null +++ b/lib/Moose/Meta/Mixin/AttributeCore.pm @@ -0,0 +1,184 @@ +package Moose::Meta::Mixin::AttributeCore; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use parent 'Class::MOP::Mixin::AttributeCore'; + +__PACKAGE__->meta->add_attribute( + 'isa' => ( + reader => '_isa_metadata', + Class::MOP::_definition_context(), + ) +); + +__PACKAGE__->meta->add_attribute( + 'does' => ( + reader => '_does_metadata', + Class::MOP::_definition_context(), + ) +); + +__PACKAGE__->meta->add_attribute( + 'is' => ( + reader => '_is_metadata', + Class::MOP::_definition_context(), + ) +); + +__PACKAGE__->meta->add_attribute( + 'required' => ( + reader => 'is_required', + Class::MOP::_definition_context(), + ) +); + +__PACKAGE__->meta->add_attribute( + 'lazy' => ( + reader => 'is_lazy', Class::MOP::_definition_context(), + ) +); + +__PACKAGE__->meta->add_attribute( + 'lazy_build' => ( + reader => 'is_lazy_build', + Class::MOP::_definition_context(), + ) +); + +__PACKAGE__->meta->add_attribute( + 'coerce' => ( + reader => 'should_coerce', + Class::MOP::_definition_context(), + ) +); + +__PACKAGE__->meta->add_attribute( + 'weak_ref' => ( + reader => 'is_weak_ref', + Class::MOP::_definition_context(), + ) +); + +__PACKAGE__->meta->add_attribute( + 'auto_deref' => ( + reader => 'should_auto_deref', + Class::MOP::_definition_context(), + ) +); + +__PACKAGE__->meta->add_attribute( + 'type_constraint' => ( + reader => 'type_constraint', + predicate => 'has_type_constraint', + Class::MOP::_definition_context(), + ) +); + +__PACKAGE__->meta->add_attribute( + 'trigger' => ( + reader => 'trigger', + predicate => 'has_trigger', + Class::MOP::_definition_context(), + ) +); + +__PACKAGE__->meta->add_attribute( + 'handles' => ( + reader => 'handles', + writer => '_set_handles', + predicate => 'has_handles', + Class::MOP::_definition_context(), + ) +); + +__PACKAGE__->meta->add_attribute( + 'documentation' => ( + reader => 'documentation', + predicate => 'has_documentation', + Class::MOP::_definition_context(), + ) +); + +1; + +# ABSTRACT: Core attributes shared by attribute metaclasses + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Mixin::AttributeCore - Core attributes shared by attribute metaclasses + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class implements the core attributes (aka properties) shared by all Moose +attributes. See the L<Moose::Meta::Attribute> documentation for API details. + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Object/Trait.pm b/lib/Moose/Meta/Object/Trait.pm new file mode 100644 index 0000000..ed23f22 --- /dev/null +++ b/lib/Moose/Meta/Object/Trait.pm @@ -0,0 +1,107 @@ +package Moose::Meta::Object::Trait; +our $VERSION = '2.1405'; + +use Scalar::Util qw(blessed); + +sub _get_compatible_metaclass { + my $orig = shift; + my $self = shift; + return $self->$orig(@_) + || $self->_get_compatible_metaclass_by_role_reconciliation(@_); +} + +sub _get_compatible_metaclass_by_role_reconciliation { + my $self = shift; + my ($other_name) = @_; + my $meta_name = blessed($self) ? $self->_real_ref_name : $self; + + return unless Moose::Util::_classes_differ_by_roles_only( + $meta_name, $other_name + ); + + return Moose::Util::_reconcile_roles_for_metaclass( + $meta_name, $other_name + ); +} + +1; + +# ABSTRACT: Some overrides for L<Class::MOP::Object> functionality + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Object::Trait - Some overrides for L<Class::MOP::Object> functionality + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This module is entirely private, you shouldn't ever need to interact with +it directly. + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Role.pm b/lib/Moose/Meta/Role.pm new file mode 100644 index 0000000..fbd8c1e --- /dev/null +++ b/lib/Moose/Meta/Role.pm @@ -0,0 +1,1095 @@ +package Moose::Meta::Role; +our $VERSION = '2.1405'; + +use strict; +use warnings; +use metaclass; + +use Scalar::Util 'blessed'; + +use Moose::Meta::Class; +use Moose::Meta::Role::Attribute; +use Moose::Meta::Role::Method; +use Moose::Meta::Role::Method::Required; +use Moose::Meta::Role::Method::Conflicting; +use Moose::Meta::Method::Meta; +use Moose::Util qw/throw_exception/; +use Class::MOP::MiniTrait; + +use parent 'Class::MOP::Module', + 'Class::MOP::Mixin::HasAttributes', + 'Class::MOP::Mixin::HasMethods', + 'Class::MOP::Mixin::HasOverloads'; + +Class::MOP::MiniTrait::apply(__PACKAGE__, 'Moose::Meta::Object::Trait'); + +## ------------------------------------------------------------------ +## NOTE: +## I normally don't do this, but I am doing +## a whole bunch of meta-programmin' in this +## module, so it just makes sense. For a clearer +## picture of what is going on in the next +## several lines of code, look at the really +## big comment at the end of this file (right +## before the POD). +## - SL +## ------------------------------------------------------------------ + +my $META = __PACKAGE__->meta; + +## ------------------------------------------------------------------ +## attributes ... + +# NOTE: +# since roles are lazy, we hold all the attributes +# of the individual role in 'stasis' until which +# time when it is applied to a class. This means +# keeping a lot of things in hash maps, so we are +# using a little of that meta-programmin' magic +# here and saving lots of extra typin'. And since +# many of these attributes above require similar +# functionality to support them, so we again use +# the wonders of meta-programmin' to deliver a +# very compact solution to this normally verbose +# problem. +# - SL + +foreach my $action ( + { + name => 'excluded_roles_map', + attr_reader => 'get_excluded_roles_map' , + methods => { + add => 'add_excluded_roles', + get_keys => 'get_excluded_roles_list', + existence => 'excludes_role', + } + }, + { + name => 'required_methods', + attr_reader => 'get_required_methods_map', + methods => { + remove => 'remove_required_methods', + get_values => 'get_required_method_list', + existence => 'requires_method', + } + }, +) { + + my $attr_reader = $action->{attr_reader}; + my $methods = $action->{methods}; + + # create the attribute + $META->add_attribute($action->{name} => ( + reader => $attr_reader, + default => sub { {} }, + Class::MOP::_definition_context(), + )); + + # create some helper methods + $META->add_method($methods->{add} => sub { + my ($self, @values) = @_; + $self->$attr_reader->{$_} = undef foreach @values; + }) if exists $methods->{add}; + + $META->add_method($methods->{get_keys} => sub { + my ($self) = @_; + keys %{$self->$attr_reader}; + }) if exists $methods->{get_keys}; + + $META->add_method($methods->{get_values} => sub { + my ($self) = @_; + values %{$self->$attr_reader}; + }) if exists $methods->{get_values}; + + $META->add_method($methods->{get} => sub { + my ($self, $name) = @_; + $self->$attr_reader->{$name} + }) if exists $methods->{get}; + + $META->add_method($methods->{existence} => sub { + my ($self, $name) = @_; + exists $self->$attr_reader->{$name} ? 1 : 0; + }) if exists $methods->{existence}; + + $META->add_method($methods->{remove} => sub { + my ($self, @values) = @_; + delete $self->$attr_reader->{$_} foreach @values; + }) if exists $methods->{remove}; +} + +$META->add_attribute( + 'method_metaclass', + reader => 'method_metaclass', + default => 'Moose::Meta::Role::Method', + Class::MOP::_definition_context(), +); + +$META->add_attribute( + 'required_method_metaclass', + reader => 'required_method_metaclass', + default => 'Moose::Meta::Role::Method::Required', + Class::MOP::_definition_context(), +); + +$META->add_attribute( + 'conflicting_method_metaclass', + reader => 'conflicting_method_metaclass', + default => 'Moose::Meta::Role::Method::Conflicting', + Class::MOP::_definition_context(), +); + +$META->add_attribute( + 'application_to_class_class', + reader => 'application_to_class_class', + default => 'Moose::Meta::Role::Application::ToClass', + Class::MOP::_definition_context(), +); + +$META->add_attribute( + 'application_to_role_class', + reader => 'application_to_role_class', + default => 'Moose::Meta::Role::Application::ToRole', + Class::MOP::_definition_context(), +); + +$META->add_attribute( + 'application_to_instance_class', + reader => 'application_to_instance_class', + default => 'Moose::Meta::Role::Application::ToInstance', + Class::MOP::_definition_context(), +); + +$META->add_attribute( + 'applied_attribute_metaclass', + reader => 'applied_attribute_metaclass', + default => 'Moose::Meta::Attribute', + Class::MOP::_definition_context(), +); + +# More or less copied from Moose::Meta::Class +sub initialize { + my $class = shift; + my @args = @_; + unshift @args, 'package' if @args % 2; + my %opts = @args; + my $package = delete $opts{package}; + return Class::MOP::get_metaclass_by_name($package) + || $class->SUPER::initialize($package, + 'attribute_metaclass' => 'Moose::Meta::Role::Attribute', + %opts, + ); +} + +sub reinitialize { + my $self = shift; + my $pkg = shift; + + my $meta = blessed $pkg ? $pkg : Class::MOP::class_of($pkg); + + my %existing_classes; + if ($meta) { + %existing_classes = map { $_ => $meta->$_() } qw( + attribute_metaclass + method_metaclass + wrapped_method_metaclass + required_method_metaclass + conflicting_method_metaclass + application_to_class_class + application_to_role_class + application_to_instance_class + applied_attribute_metaclass + ); + } + + my %options = @_; + $options{weaken} = Class::MOP::metaclass_is_weak($meta->name) + if !exists $options{weaken} + && blessed($meta) + && $meta->isa('Moose::Meta::Role'); + + # don't need to remove generated metaobjects here yet, since we don't + # yet generate anything in roles. this may change in the future though... + # keep an eye on that + my $new_meta = $self->SUPER::reinitialize( + $pkg, + %existing_classes, + %options, + ); + $new_meta->_restore_metaobjects_from($meta) + if $meta && $meta->isa('Moose::Meta::Role'); + return $new_meta; +} + +sub _restore_metaobjects_from { + my $self = shift; + my ($old_meta) = @_; + + $self->_restore_metamethods_from($old_meta); + $self->_restore_metaattributes_from($old_meta); + + for my $role ( @{ $old_meta->get_roles } ) { + $self->add_role($role); + } +} + +sub add_attribute { + my $self = shift; + + if (blessed $_[0] && ! $_[0]->isa('Moose::Meta::Role::Attribute') ) { + my $class = ref $_[0]; + throw_exception( CannotAddAsAnAttributeToARole => role_name => $self->name, + attribute_class => $class, + ); + } + elsif (!blessed($_[0]) && defined($_[0]) && $_[0] =~ /^\+(.*)/) { + throw_exception( AttributeExtensionIsNotSupportedInRoles => attribute_name => $_[0], + role_name => $self->name, + ); + } + + return $self->SUPER::add_attribute(@_); +} + +sub _attach_attribute { + my ( $self, $attribute ) = @_; + + $attribute->attach_to_role($self); +} + +sub add_required_methods { + my $self = shift; + + for (@_) { + my $method = $_; + if (!blessed($method)) { + $method = $self->required_method_metaclass->new( + name => $method, + ); + } + $self->get_required_methods_map->{$method->name} = $method; + } +} + +sub add_conflicting_method { + my $self = shift; + + my $method; + if (@_ == 1 && blessed($_[0])) { + $method = shift; + } + else { + $method = $self->conflicting_method_metaclass->new(@_); + } + + $self->add_required_methods($method); +} + +## ------------------------------------------------------------------ +## method modifiers + +# NOTE: +# the before/around/after method modifiers are +# stored by name, but there can be many methods +# then associated with that name. So again we have +# lots of similar functionality, so we can do some +# meta-programmin' and save some time. +# - SL + +foreach my $modifier_type (qw[ before around after ]) { + + my $attr_reader = "get_${modifier_type}_method_modifiers_map"; + + # create the attribute ... + $META->add_attribute("${modifier_type}_method_modifiers" => ( + reader => $attr_reader, + default => sub { {} }, + Class::MOP::_definition_context(), + )); + + # and some helper methods ... + $META->add_method("get_${modifier_type}_method_modifiers" => sub { + my ($self, $method_name) = @_; + #return () unless exists $self->$attr_reader->{$method_name}; + my $mm = $self->$attr_reader->{$method_name}; + $mm ? @$mm : (); + }); + + $META->add_method("has_${modifier_type}_method_modifiers" => sub { + my ($self, $method_name) = @_; + # NOTE: + # for now we assume that if it exists,.. + # it has at least one modifier in it + (exists $self->$attr_reader->{$method_name}) ? 1 : 0; + }); + + $META->add_method("add_${modifier_type}_method_modifier" => sub { + my ($self, $method_name, $method) = @_; + + $self->$attr_reader->{$method_name} = [] + unless exists $self->$attr_reader->{$method_name}; + + my $modifiers = $self->$attr_reader->{$method_name}; + + # NOTE: + # check to see that we aren't adding the + # same code twice. We err in favor of the + # first on here, this may not be as expected + foreach my $modifier (@{$modifiers}) { + return if $modifier == $method; + } + + push @{$modifiers} => $method; + }); + +} + +## ------------------------------------------------------------------ +## override method modifiers + +$META->add_attribute('override_method_modifiers' => ( + reader => 'get_override_method_modifiers_map', + default => sub { {} }, + Class::MOP::_definition_context(), +)); + +# NOTE: +# these are a little different because there +# can only be one per name, whereas the other +# method modifiers can have multiples. +# - SL + +sub add_override_method_modifier { + my ($self, $method_name, $method) = @_; + (!$self->has_method($method_name)) + || throw_exception( CannotOverrideALocalMethod => method_name => $method_name, + role_name => $self->name, + ); + $self->get_override_method_modifiers_map->{$method_name} = $method; +} + +sub has_override_method_modifier { + my ($self, $method_name) = @_; + # NOTE: + # for now we assume that if it exists,.. + # it has at least one modifier in it + (exists $self->get_override_method_modifiers_map->{$method_name}) ? 1 : 0; +} + +sub get_override_method_modifier { + my ($self, $method_name) = @_; + $self->get_override_method_modifiers_map->{$method_name}; +} + +## general list accessor ... + +sub get_method_modifier_list { + my ($self, $modifier_type) = @_; + my $accessor = "get_${modifier_type}_method_modifiers_map"; + keys %{$self->$accessor}; +} + +sub _meta_method_class { 'Moose::Meta::Method::Meta' } + +## ------------------------------------------------------------------ +## subroles + +$META->add_attribute('roles' => ( + reader => 'get_roles', + default => sub { [] }, + Class::MOP::_definition_context(), +)); + +sub add_role { + my ($self, $role) = @_; + (blessed($role) && $role->isa('Moose::Meta::Role')) + || throw_exception( AddRoleToARoleTakesAMooseMetaRole => role_to_be_added => $role, + role_name => $self->name, + ); + push @{$self->get_roles} => $role; + $self->reset_package_cache_flag; +} + +sub calculate_all_roles { + my $self = shift; + my %seen; + grep { + !$seen{$_->name}++ + } ($self, map { + $_->calculate_all_roles + } @{ $self->get_roles }); +} + +sub does_role { + my ($self, $role) = @_; + (defined $role) + || throw_exception( RoleNameRequiredForMooseMetaRole => role_name => $self->name ); + my $role_name = blessed $role ? $role->name : $role; + # if we are it,.. then return true + return 1 if $role_name eq $self->name; + # otherwise.. check our children + foreach my $role (@{$self->get_roles}) { + return 1 if $role->does_role($role_name); + } + return 0; +} + +sub find_method_by_name { (shift)->get_method(@_) } + +## ------------------------------------------------------------------ +## role construction +## ------------------------------------------------------------------ + +sub apply { + my ($self, $other, %args) = @_; + + (blessed($other)) + || throw_exception( ApplyTakesABlessedInstance => param => $other, + role_name => $self->name, + ); + + my $application_class; + if ($other->isa('Moose::Meta::Role')) { + $application_class = $self->application_to_role_class; + } + elsif ($other->isa('Moose::Meta::Class')) { + $application_class = $self->application_to_class_class; + } + else { + $application_class = $self->application_to_instance_class; + } + + Moose::Util::_load_user_class($application_class); + + if ( exists $args{'-excludes'} ) { + # I wish we had coercion here :) + $args{'-excludes'} = ( + ref $args{'-excludes'} eq 'ARRAY' + ? $args{'-excludes'} + : [ $args{'-excludes'} ] + ); + } + + return $application_class->new(%args)->apply($self, $other, \%args); +} + +sub composition_class_roles { } + +sub combine { + my ($class, @role_specs) = @_; + + require Moose::Meta::Role::Composite; + + my (@roles, %role_params); + while (@role_specs) { + my ($role, $params) = @{ splice @role_specs, 0, 1 }; + my $requested_role + = blessed $role + ? $role + : Class::MOP::class_of($role); + + my $actual_role = $requested_role->_role_for_combination($params); + push @roles => $actual_role; + + next unless defined $params; + $role_params{$actual_role->name} = $params; + } + + my $c = Moose::Meta::Role::Composite->new(roles => \@roles); + return $c->apply_params(\%role_params); +} + +sub _role_for_combination { + my ($self, $params) = @_; + return $self; +} + +sub create { + my $class = shift; + my @args = @_; + + unshift @args, 'package' if @args % 2 == 1; + my %options = @args; + + (ref $options{attributes} eq 'HASH') + || throw_exception( CreateTakesHashRefOfAttributes => params => \%options, + attribute_class => $class + ) + if exists $options{attributes}; + + (ref $options{methods} eq 'HASH') + || throw_exception( CreateTakesHashRefOfMethods => params => \%options, + attribute_class => $class + ) + if exists $options{methods}; + + (ref $options{roles} eq 'ARRAY') + || throw_exception( CreateTakesArrayRefOfRoles => params => \%options, + attribute_class => $class + ) + if exists $options{roles}; + + my $package = delete $options{package}; + my $roles = delete $options{roles}; + my $attributes = delete $options{attributes}; + my $methods = delete $options{methods}; + my $meta_name = exists $options{meta_name} + ? delete $options{meta_name} + : 'meta'; + + my $meta = $class->SUPER::create($package => %options); + + $meta->_add_meta_method($meta_name) + if defined $meta_name; + + if (defined $attributes) { + foreach my $attribute_name (keys %{$attributes}) { + my $attr = $attributes->{$attribute_name}; + $meta->add_attribute( + $attribute_name => blessed $attr ? $attr : %{$attr} ); + } + } + + if (defined $methods) { + foreach my $method_name (keys %{$methods}) { + $meta->add_method($method_name, $methods->{$method_name}); + } + } + + if ($roles) { + Moose::Util::apply_all_roles($meta, @$roles); + } + + return $meta; +} + +sub consumers { + my $self = shift; + my @consumers; + for my $meta (Class::MOP::get_all_metaclass_instances) { + next if $meta->name eq $self->name; + next unless $meta->isa('Moose::Meta::Class') + || $meta->isa('Moose::Meta::Role'); + push @consumers, $meta->name + if $meta->does_role($self->name); + } + return @consumers; +} + +# XXX: something more intelligent here? +sub _anon_package_prefix { 'Moose::Meta::Role::__ANON__::SERIAL::' } + +sub create_anon_role { shift->create_anon(@_) } +sub is_anon_role { shift->is_anon(@_) } + +sub _anon_cache_key { + my $class = shift; + my %options = @_; + + # XXX fix this duplication (see MMC::_anon_cache_key + my $roles = Data::OptList::mkopt(($options{roles} || []), { + moniker => 'role', + val_test => sub { ref($_[0]) eq 'HASH' }, + }); + + my @role_keys; + for my $role_spec (@$roles) { + my ($role, $params) = @$role_spec; + $params = { %$params }; + + my $key = blessed($role) ? $role->name : $role; + + if ($params && %$params) { + my $alias = delete $params->{'-alias'} + || delete $params->{'alias'} + || {}; + my $excludes = delete $params->{'-excludes'} + || delete $params->{'excludes'} + || []; + $excludes = [$excludes] unless ref($excludes) eq 'ARRAY'; + + if (%$params) { + warn "Roles with parameters cannot be cached. Consider " + . "applying the parameters before calling " + . "create_anon_class, or using 'weaken => 0' instead"; + return; + } + + my $alias_key = join('%', + map { $_ => $alias->{$_} } sort keys %$alias + ); + my $excludes_key = join('%', + sort @$excludes + ); + $key .= '<' . join('+', 'a', $alias_key, 'e', $excludes_key) . '>'; + } + + push @role_keys, $key; + } + + # Makes something like Role|Role::1 + return join('|', sort @role_keys); +} + +##################################################################### +## NOTE: +## This is Moose::Meta::Role as defined by Moose (plus the use of +## MooseX::AttributeHelpers module). It is here as a reference to +## make it easier to see what is happening above with all the meta +## programming. - SL +##################################################################### +# +# has 'roles' => ( +# metaclass => 'Array', +# reader => 'get_roles', +# isa => 'ArrayRef[Moose::Meta::Role]', +# default => sub { [] }, +# provides => { +# 'push' => 'add_role', +# } +# ); +# +# has 'excluded_roles_map' => ( +# metaclass => 'Hash', +# reader => 'get_excluded_roles_map', +# isa => 'HashRef[Str]', +# provides => { +# # Not exactly set, cause it sets multiple +# 'set' => 'add_excluded_roles', +# 'keys' => 'get_excluded_roles_list', +# 'exists' => 'excludes_role', +# } +# ); +# +# has 'required_methods' => ( +# metaclass => 'Hash', +# reader => 'get_required_methods_map', +# isa => 'HashRef[Moose::Meta::Role::Method::Required]', +# provides => { +# # not exactly set, or delete since it works for multiple +# 'set' => 'add_required_methods', +# 'delete' => 'remove_required_methods', +# 'keys' => 'get_required_method_list', +# 'exists' => 'requires_method', +# } +# ); +# +# # the before, around and after modifiers are +# # HASH keyed by method-name, with ARRAY of +# # CODE refs to apply in that order +# +# has 'before_method_modifiers' => ( +# metaclass => 'Hash', +# reader => 'get_before_method_modifiers_map', +# isa => 'HashRef[ArrayRef[CodeRef]]', +# provides => { +# 'keys' => 'get_before_method_modifiers', +# 'exists' => 'has_before_method_modifiers', +# # This actually makes sure there is an +# # ARRAY at the given key, and pushed onto +# # it. It also checks for duplicates as well +# # 'add' => 'add_before_method_modifier' +# } +# ); +# +# has 'after_method_modifiers' => ( +# metaclass => 'Hash', +# reader =>'get_after_method_modifiers_map', +# isa => 'HashRef[ArrayRef[CodeRef]]', +# provides => { +# 'keys' => 'get_after_method_modifiers', +# 'exists' => 'has_after_method_modifiers', +# # This actually makes sure there is an +# # ARRAY at the given key, and pushed onto +# # it. It also checks for duplicates as well +# # 'add' => 'add_after_method_modifier' +# } +# ); +# +# has 'around_method_modifiers' => ( +# metaclass => 'Hash', +# reader =>'get_around_method_modifiers_map', +# isa => 'HashRef[ArrayRef[CodeRef]]', +# provides => { +# 'keys' => 'get_around_method_modifiers', +# 'exists' => 'has_around_method_modifiers', +# # This actually makes sure there is an +# # ARRAY at the given key, and pushed onto +# # it. It also checks for duplicates as well +# # 'add' => 'add_around_method_modifier' +# } +# ); +# +# # override is similar to the other modifiers +# # except that it is not an ARRAY of code refs +# # but instead just a single name->code mapping +# +# has 'override_method_modifiers' => ( +# metaclass => 'Hash', +# reader =>'get_override_method_modifiers_map', +# isa => 'HashRef[CodeRef]', +# provides => { +# 'keys' => 'get_override_method_modifier', +# 'exists' => 'has_override_method_modifier', +# 'add' => 'add_override_method_modifier', # checks for local method .. +# } +# ); +# +##################################################################### + + +1; + +# ABSTRACT: The Moose Role metaclass + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Role - The Moose Role metaclass + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class is a subclass of L<Class::MOP::Module> that provides +additional Moose-specific functionality. + +Its API looks a lot like L<Moose::Meta::Class>, but internally it +implements many things differently. This may change in the future. + +=head1 INHERITANCE + +C<Moose::Meta::Role> is a subclass of L<Class::MOP::Module>. + +=head1 METHODS + +=head2 Construction + +=over 4 + +=item B<< Moose::Meta::Role->initialize($role_name) >> + +This method creates a new role object with the provided name. + +=item B<< Moose::Meta::Role->combine( [ $role => { ... } ], [ $role ], ... ) >> + +This method accepts a list of array references. Each array reference +should contain a role name or L<Moose::Meta::Role> object as its first element. The second element is +an optional hash reference. The hash reference can contain C<-excludes> +and C<-alias> keys to control how methods are composed from the role. + +The return value is a new L<Moose::Meta::Role::Composite> that +represents the combined roles. + +=item B<< $metarole->composition_class_roles >> + +When combining multiple roles using C<combine>, this method is used to obtain a +list of role names to be applied to the L<Moose::Meta::Role::Composite> +instance returned by C<combine>. The default implementation returns an empty +list. Extensions that need to hook into role combination may wrap this method +to return additional role names. + +=item B<< Moose::Meta::Role->create($name, %options) >> + +This method is identical to the L<Moose::Meta::Class> C<create> +method. + +=item B<< Moose::Meta::Role->create_anon_role >> + +This method is identical to the L<Moose::Meta::Class> +C<create_anon_class> method. + +=item B<< $metarole->is_anon_role >> + +Returns true if the role is an anonymous role. + +=item B<< $metarole->consumers >> + +Returns a list of names of classes and roles which consume this role. + +=back + +=head2 Role application + +=over 4 + +=item B<< $metarole->apply( $thing, @options ) >> + +This method applies a role to the given C<$thing>. That can be another +L<Moose::Meta::Role>, object, a L<Moose::Meta::Class> object, or a +(non-meta) object instance. + +The options are passed directly to the constructor for the appropriate +L<Moose::Meta::Role::Application> subclass. + +Note that this will apply the role even if the C<$thing> in question already +C<does> this role. L<Moose::Util/does_role> is a convenient wrapper for +finding out if role application is necessary. + +=back + +=head2 Roles and other roles + +=over 4 + +=item B<< $metarole->get_roles >> + +This returns an array reference of roles which this role does. This +list may include duplicates. + +=item B<< $metarole->calculate_all_roles >> + +This returns a I<unique> list of all roles that this role does, and +all the roles that its roles do. + +=item B<< $metarole->does_role($role) >> + +Given a role I<name> or L<Moose::Meta::Role> object, returns true if this role +does the given role. + +=item B<< $metarole->add_role($role) >> + +Given a L<Moose::Meta::Role> object, this adds the role to the list of +roles that the role does. + +=item B<< $metarole->get_excluded_roles_list >> + +Returns a list of role names which this role excludes. + +=item B<< $metarole->excludes_role($role_name) >> + +Given a role I<name>, returns true if this role excludes the named +role. + +=item B<< $metarole->add_excluded_roles(@role_names) >> + +Given one or more role names, adds those roles to the list of excluded +roles. + +=back + +=head2 Methods + +The methods for dealing with a role's methods are all identical in API +and behavior to the same methods in L<Class::MOP::Class>. + +=over 4 + +=item B<< $metarole->method_metaclass >> + +Returns the method metaclass name for the role. This defaults to +L<Moose::Meta::Role::Method>. + +=item B<< $metarole->get_method($name) >> + +=item B<< $metarole->has_method($name) >> + +=item B<< $metarole->add_method( $name, $body ) >> + +=item B<< $metarole->get_method_list >> + +=item B<< $metarole->find_method_by_name($name) >> + +These methods are all identical to the methods of the same name in +L<Class::MOP::Package> + +=back + +=head2 Attributes + +As with methods, the methods for dealing with a role's attribute are +all identical in API and behavior to the same methods in +L<Class::MOP::Class>. + +However, attributes stored in this class are I<not> stored as +objects. Rather, the attribute definition is stored as a hash +reference. When a role is composed into a class, this hash reference +is passed directly to the metaclass's C<add_attribute> method. + +This is quite likely to change in the future. + +=over 4 + +=item B<< $metarole->get_attribute($attribute_name) >> + +=item B<< $metarole->has_attribute($attribute_name) >> + +=item B<< $metarole->get_attribute_list >> + +=item B<< $metarole->add_attribute($name, %options) >> + +=item B<< $metarole->remove_attribute($attribute_name) >> + +=back + +=head2 Overload introspection and creation + +The methods for dealing with a role's overloads are all identical in API and +behavior to the same methods in L<Class::MOP::Class>. + +=over 4 + +=item B<< $metarole->is_overloaded >> + +=item B<< $metarole->get_overloaded_operator($op) >> + +=item B<< $metarole->has_overloaded_operator($op) >> + +=item B<< $metarole->get_overload_list >> + +=item B<< $metarole->get_all_overloaded_operators >> + +=item B<< $metarole->add_overloaded_operator($op, $impl) >> + +=item B<< $metarole->remove_overloaded_operator($op) >> + +=back + +=head2 Required methods + +=over 4 + +=item B<< $metarole->get_required_method_list >> + +Returns the list of methods required by the role. + +=item B<< $metarole->requires_method($name) >> + +Returns true if the role requires the named method. + +=item B<< $metarole->add_required_methods(@names) >> + +Adds the named methods to the role's list of required methods. + +=item B<< $metarole->remove_required_methods(@names) >> + +Removes the named methods from the role's list of required methods. + +=item B<< $metarole->add_conflicting_method(%params) >> + +Instantiate the parameters as a L<Moose::Meta::Role::Method::Conflicting> +object, then add it to the required method list. + +=back + +=head2 Method modifiers + +These methods act like their counterparts in L<Class::MOP::Class> and +L<Moose::Meta::Class>. + +However, method modifiers are simply stored internally, and are not +applied until the role itself is applied to a class. + +=over 4 + +=item B<< $metarole->add_after_method_modifier($method_name, $method) >> + +=item B<< $metarole->add_around_method_modifier($method_name, $method) >> + +=item B<< $metarole->add_before_method_modifier($method_name, $method) >> + +=item B<< $metarole->add_override_method_modifier($method_name, $method) >> + +These methods all add an appropriate modifier to the internal list of +modifiers. + +=item B<< $metarole->has_after_method_modifiers >> + +=item B<< $metarole->has_around_method_modifiers >> + +=item B<< $metarole->has_before_method_modifiers >> + +=item B<< $metarole->has_override_method_modifier >> + +Return true if the role has any modifiers of the given type. + +=item B<< $metarole->get_after_method_modifiers($method_name) >> + +=item B<< $metarole->get_around_method_modifiers($method_name) >> + +=item B<< $metarole->get_before_method_modifiers($method_name) >> + +Given a method name, returns a list of the appropriate modifiers for +that method. + +=item B<< $metarole->get_override_method_modifier($method_name) >> + +Given a method name, returns the override method modifier for that +method, if it has one. + +=back + +=head2 Introspection + +=over 4 + +=item B<< Moose::Meta::Role->meta >> + +This will return a L<Class::MOP::Class> instance for this class. + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Role/Application.pm b/lib/Moose/Meta/Role/Application.pm new file mode 100644 index 0000000..58a123e --- /dev/null +++ b/lib/Moose/Meta/Role/Application.pm @@ -0,0 +1,225 @@ +package Moose::Meta::Role::Application; +our $VERSION = '2.1405'; + +use strict; +use warnings; +use metaclass; +use overload (); + +use List::Util 1.33 qw( all ); + +use Moose::Util 'throw_exception'; + +__PACKAGE__->meta->add_attribute('method_exclusions' => ( + init_arg => '-excludes', + reader => 'get_method_exclusions', + default => sub { [] }, + Class::MOP::_definition_context(), +)); + +__PACKAGE__->meta->add_attribute('method_aliases' => ( + init_arg => '-alias', + reader => 'get_method_aliases', + default => sub { {} }, + Class::MOP::_definition_context(), +)); + +sub new { + my ($class, %params) = @_; + $class->_new(\%params); +} + +sub is_method_excluded { + my ($self, $method_name) = @_; + foreach (@{$self->get_method_exclusions}) { + return 1 if $_ eq $method_name; + } + return 0; +} + +sub is_method_aliased { + my ($self, $method_name) = @_; + exists $self->get_method_aliases->{$method_name} ? 1 : 0 +} + +sub is_aliased_method { + my ($self, $method_name) = @_; + my %aliased_names = reverse %{$self->get_method_aliases}; + exists $aliased_names{$method_name} ? 1 : 0; +} + +sub apply { + my $self = shift; + + $self->check_role_exclusions(@_); + $self->check_required_methods(@_); + $self->check_required_attributes(@_); + + $self->apply_overloading(@_); + $self->apply_attributes(@_); + $self->apply_methods(@_); + + $self->apply_override_method_modifiers(@_); + + $self->apply_before_method_modifiers(@_); + $self->apply_around_method_modifiers(@_); + $self->apply_after_method_modifiers(@_); +} + +sub check_role_exclusions { throw_exception( "CannotCallAnAbstractMethod" ); } +sub check_required_methods { throw_exception( "CannotCallAnAbstractMethod" ); } +sub check_required_attributes { throw_exception( "CannotCallAnAbstractMethod" ); } + +sub apply_attributes { throw_exception( "CannotCallAnAbstractMethod" ); } +sub apply_methods { throw_exception( "CannotCallAnAbstractMethod" ); } +sub apply_override_method_modifiers { throw_exception( "CannotCallAnAbstractMethod" ); } +sub apply_method_modifiers { throw_exception( "CannotCallAnAbstractMethod" ); } + +sub apply_before_method_modifiers { (shift)->apply_method_modifiers('before' => @_) } +sub apply_around_method_modifiers { (shift)->apply_method_modifiers('around' => @_) } +sub apply_after_method_modifiers { (shift)->apply_method_modifiers('after' => @_) } + +sub apply_overloading { + my ( $self, $role, $other ) = @_; + + return unless $role->is_overloaded; + + unless ( $other->is_overloaded ) { + $other->set_overload_fallback_value( + $role->get_overload_fallback_value ); + } + + for my $overload ( $role->get_all_overloaded_operators ) { + next if $other->has_overloaded_operator( $overload->operator ); + $other->add_overloaded_operator( + $overload->operator => $overload->clone ); + } +} + +1; + +# ABSTRACT: A base class for role application + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Role::Application - A base class for role application + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This is the abstract base class for role applications. + +The API for this class and its subclasses still needs some +consideration, and is intentionally not yet documented. + +=head2 METHODS + +=over 4 + +=item B<new> + +=item B<meta> + +=item B<get_method_exclusions> + +=item B<is_method_excluded> + +=item B<get_method_aliases> + +=item B<is_aliased_method> + +=item B<is_method_aliased> + +=item B<apply> + +=item B<check_role_exclusions> + +=item B<check_required_methods> + +=item B<check_required_attributes> + +=item B<apply_attributes> + +=item B<apply_methods> + +=item B<apply_overloading> + +=item B<apply_method_modifiers> + +=item B<apply_before_method_modifiers> + +=item B<apply_after_method_modifiers> + +=item B<apply_around_method_modifiers> + +=item B<apply_override_method_modifiers> + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Role/Application/RoleSummation.pm b/lib/Moose/Meta/Role/Application/RoleSummation.pm new file mode 100644 index 0000000..1276b66 --- /dev/null +++ b/lib/Moose/Meta/Role/Application/RoleSummation.pm @@ -0,0 +1,440 @@ +package Moose::Meta::Role::Application::RoleSummation; +our $VERSION = '2.1405'; + +use strict; +use warnings; +use metaclass; + +use List::Util 1.33 qw( all ); +use Scalar::Util 'blessed'; + +use Moose::Meta::Role::Composite; + +use parent 'Moose::Meta::Role::Application'; + +use Moose::Util 'throw_exception'; + +__PACKAGE__->meta->add_attribute('role_params' => ( + reader => 'role_params', + default => sub { {} }, + Class::MOP::_definition_context(), +)); + +sub get_exclusions_for_role { + my ($self, $role) = @_; + $role = $role->name if blessed $role; + my $excludes_key = exists $self->role_params->{$role}->{'-excludes'} ? + '-excludes' : 'excludes'; + if ($self->role_params->{$role} && defined $self->role_params->{$role}->{$excludes_key}) { + if (ref $self->role_params->{$role}->{$excludes_key} eq 'ARRAY') { + return $self->role_params->{$role}->{$excludes_key}; + } + return [ $self->role_params->{$role}->{$excludes_key} ]; + } + return []; +} + +sub get_method_aliases_for_role { + my ($self, $role) = @_; + $role = $role->name if blessed $role; + my $alias_key = exists $self->role_params->{$role}->{'-alias'} ? + '-alias' : 'alias'; + if ($self->role_params->{$role} && defined $self->role_params->{$role}->{$alias_key}) { + return $self->role_params->{$role}->{$alias_key}; + } + return {}; +} + +sub is_method_excluded { + my ($self, $role, $method_name) = @_; + foreach ($self->get_exclusions_for_role($role->name)) { + return 1 if $_ eq $method_name; + } + return 0; +} + +sub is_method_aliased { + my ($self, $role, $method_name) = @_; + exists $self->get_method_aliases_for_role($role->name)->{$method_name} ? 1 : 0 +} + +sub is_aliased_method { + my ($self, $role, $method_name) = @_; + my %aliased_names = reverse %{$self->get_method_aliases_for_role($role->name)}; + exists $aliased_names{$method_name} ? 1 : 0; +} + +sub check_role_exclusions { + my ($self, $c) = @_; + + my %excluded_roles; + for my $role (@{ $c->get_roles }) { + my $name = $role->name; + + for my $excluded ($role->get_excluded_roles_list) { + push @{ $excluded_roles{$excluded} }, $name; + } + } + + foreach my $role (@{$c->get_roles}) { + foreach my $excluded (keys %excluded_roles) { + next unless $role->does_role($excluded); + + my @excluding = @{ $excluded_roles{$excluded} }; + + throw_exception( RoleExclusionConflict => roles => \@excluding, + role_name => $excluded + ); + } + } + + $c->add_excluded_roles(keys %excluded_roles); +} + +sub check_required_methods { + my ($self, $c) = @_; + + my %all_required_methods = + map { $_->name => $_ } + map { $_->get_required_method_list } + @{$c->get_roles}; + + foreach my $role (@{$c->get_roles}) { + foreach my $required (keys %all_required_methods) { + + delete $all_required_methods{$required} + if $role->has_method($required) + || $self->is_aliased_method($role, $required); + } + } + + $c->add_required_methods(values %all_required_methods); +} + +sub check_required_attributes { + +} + +sub apply_attributes { + my ($self, $c) = @_; + + my @all_attributes; + + for my $role ( @{ $c->get_roles } ) { + push @all_attributes, + map { $role->get_attribute($_) } $role->get_attribute_list; + } + + my %seen; + foreach my $attr (@all_attributes) { + my $name = $attr->name; + + if ( exists $seen{$name} ) { + next if $seen{$name}->is_same_as($attr); + + my $role1 = $seen{$name}->associated_role->name; + my $role2 = $attr->associated_role->name; + + throw_exception( AttributeConflictInSummation => attribute_name => $name, + role_name => $role1, + second_role_name => $role2, + ); + } + + $seen{$name} = $attr; + } + + foreach my $attr (@all_attributes) { + $c->add_attribute( $attr->clone ); + } +} + +sub apply_methods { + my ($self, $c) = @_; + + my @all_methods = map { + my $role = $_; + my $aliases = $self->get_method_aliases_for_role($role); + my %excludes = map { $_ => undef } @{ $self->get_exclusions_for_role($role) }; + ( + (map { + exists $excludes{$_} ? () : + +{ + role => $role, + name => $_, + method => $role->get_method($_), + } + } map { $_->name } + grep { !$_->isa('Class::MOP::Method::Meta') } + $role->_get_local_methods), + (map { + +{ + role => $role, + name => $aliases->{$_}, + method => $role->get_method($_), + } + } keys %$aliases) + ); + } @{$c->get_roles}; + + my (%seen, %conflicts, %method_map); + foreach my $method (@all_methods) { + next if $conflicts{$method->{name}}; + my $seen = $seen{$method->{name}}; + + if ($seen) { + if ($seen->{method}->body != $method->{method}->body) { + $c->add_conflicting_method( + name => $method->{name}, + roles => [$method->{role}->name, $seen->{role}->name], + ); + + delete $method_map{$method->{name}}; + $conflicts{$method->{name}} = 1; + next; + } + } + + $seen{$method->{name}} = $method; + $method_map{$method->{name}} = $method->{method}; + } + + $c->add_method($_ => $method_map{$_}) for keys %method_map; +} + +sub apply_override_method_modifiers { + my ($self, $c) = @_; + + my @all_overrides = map { + my $role = $_; + map { + +{ + name => $_, + method => $role->get_override_method_modifier($_), + } + } $role->get_method_modifier_list('override'); + } @{$c->get_roles}; + + my %seen; + foreach my $override (@all_overrides) { + my @role_names = map { $_->name } @{$c->get_roles}; + if ( $c->has_method($override->{name}) ){ + throw_exception( OverrideConflictInSummation => role_names => \@role_names, + role_application => $self, + method_name => $override->{name} + ); + } + if (exists $seen{$override->{name}}) { + if ( $seen{$override->{name}} != $override->{method} ) { + throw_exception( OverrideConflictInSummation => role_names => \@role_names, + role_application => $self, + method_name => $override->{name}, + two_overrides_found => 1 + ); + } + } + $seen{$override->{name}} = $override->{method}; + } + + $c->add_override_method_modifier( + $_->{name}, $_->{method} + ) for @all_overrides; + +} + +sub apply_method_modifiers { + my ($self, $modifier_type, $c) = @_; + my $add = "add_${modifier_type}_method_modifier"; + my $get = "get_${modifier_type}_method_modifiers"; + foreach my $role (@{$c->get_roles}) { + foreach my $method_name ($role->get_method_modifier_list($modifier_type)) { + $c->$add( + $method_name, + $_ + ) foreach $role->$get($method_name); + } + } +} + +sub apply_overloading { + my ( $self, $c ) = @_; + + my @overloaded_roles = grep { $_->is_overloaded } @{ $c->get_roles }; + return unless @overloaded_roles; + + my %fallback; + for my $role (@overloaded_roles) { + $fallback{ $role->name } = $role->get_overload_fallback_value; + } + + for my $role_name ( keys %fallback ) { + for my $other_role_name ( grep { $_ ne $role_name } keys %fallback ) { + my @fb_values = @fallback{ $role_name, $other_role_name }; + if ( all {defined} @fb_values ) { + next if $fallback{$role_name} eq $fallback{$other_role_name}; + throw_exception( + 'OverloadConflictInSummation', + role_names => [ $role_name, $other_role_name ], + role_application => $self, + overloaded_op => 'fallback', + ); + } + + next if all { !defined } @fb_values; + throw_exception( + 'OverloadConflictInSummation', + role_names => [ $role_name, $other_role_name ], + role_application => $self, + overloaded_op => 'fallback', + ); + } + } + + if ( keys %fallback ) { + $c->set_overload_fallback_value( ( values %fallback )[0] ); + } + + my %overload_map; + for my $role (@overloaded_roles) { + for my $overload ( $role->get_all_overloaded_operators ) { + $overload_map{ $overload->operator }{ $role->name } = $overload; + } + } + + for my $op_name ( keys %overload_map ) { + my @roles = keys %{ $overload_map{$op_name} }; + my $overload = $overload_map{$op_name}{ $roles[0] }; + + if ( @roles > 1 && !all { $overload->_is_equal_to($_) } + values %{ $overload_map{$op_name} } ) { + + throw_exception( + 'OverloadConflictInSummation', + role_names => [ @roles[ 0, 1 ] ], + role_application => $self, + overloaded_op => $op_name, + ); + } + + $c->add_overloaded_operator( + $op_name => $overload_map{$op_name}{ $roles[0] } ); + } +} + +1; + +# ABSTRACT: Combine two or more roles + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Role::Application::RoleSummation - Combine two or more roles + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +Summation composes two traits, forming the union of non-conflicting +bindings and 'disabling' the conflicting bindings + +=head2 METHODS + +=over 4 + +=item B<new> + +=item B<meta> + +=item B<role_params> + +=item B<get_exclusions_for_role> + +=item B<get_method_aliases_for_role> + +=item B<is_aliased_method> + +=item B<is_method_aliased> + +=item B<is_method_excluded> + +=item B<apply> + +=item B<check_role_exclusions> + +=item B<check_required_methods> + +=item B<check_required_attributes> + +=item B<apply_attributes> + +=item B<apply_methods> + +=item B<apply_overloading> + +=item B<apply_method_modifiers> + +=item B<apply_override_method_modifiers> + +=back + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Role/Application/ToClass.pm b/lib/Moose/Meta/Role/Application/ToClass.pm new file mode 100644 index 0000000..03eeedd --- /dev/null +++ b/lib/Moose/Meta/Role/Application/ToClass.pm @@ -0,0 +1,314 @@ +package Moose::Meta::Role::Application::ToClass; +our $VERSION = '2.1405'; + +use strict; +use warnings; +use metaclass; + +use List::Util 'first'; +use Moose::Util 'throw_exception'; +use Scalar::Util 'weaken'; + +use parent 'Moose::Meta::Role::Application'; + +__PACKAGE__->meta->add_attribute('role' => ( + reader => 'role', + Class::MOP::_definition_context(), +)); + +__PACKAGE__->meta->add_attribute('class' => ( + accessor => 'class', + Class::MOP::_definition_context(), +)); + +sub apply { + my ($self, $role, $class) = @_; + + # We need weak_ref in CMOP :( + weaken($self->{role} = $role); + weaken($self->{class} = $class); + + $self->SUPER::apply($role, $class); + + $class->add_role($role); + $class->add_role_application($self); +} + +sub check_role_exclusions { + my ($self, $role, $class) = @_; + if ($class->excludes_role($role->name)) { + throw_exception( ConflictDetectedInCheckRoleExclusionsInToClass => class_name => $class->name, + role_name => $role->name, + ); + } + foreach my $excluded_role_name ($role->get_excluded_roles_list) { + if ($class->does_role($excluded_role_name)) { + throw_exception( ClassDoesTheExcludedRole => role_name => $role->name, + excluded_role_name => $excluded_role_name, + class_name => $class->name, + ); + } + } +} + +sub check_required_methods { + my ($self, $role, $class) = @_; + + my @missing; + my @is_attr; + + # NOTE: + # we might need to move this down below the + # the attributes so that we can require any + # attribute accessors. However I am thinking + # that maybe those are somehow exempt from + # the require methods stuff. + foreach my $required_method ($role->get_required_method_list) { + my $required_method_name = $required_method->name; + + if (!$class->find_method_by_name($required_method_name)) { + + next if $self->is_aliased_method($required_method_name); + + push @missing, $required_method; + } + } + + return unless @missing; + + my $error = ''; + + @missing = sort { $a->name cmp $b->name } @missing; + my @conflicts = grep { $_->isa('Moose::Meta::Role::Method::Conflicting') } @missing; + + if (@conflicts) { + my $conflict = $conflicts[0]; + my $roles = $conflict->roles_as_english_list; + + my @same_role_conflicts = grep { $_->roles_as_english_list eq $roles } @conflicts; + + throw_exception( MethodNameConflictInRoles => conflict => \@same_role_conflicts, + class_name => $class->name + ); + } + elsif (@missing) { + if (my $meth = first { $class->name->can($_) } @missing) { + throw_exception( RequiredMethodsImportedByClass => class_name => $class->name, + role_name => $role->name, + missing_methods => \@missing, + imported_method => $meth + ); + } + else { + throw_exception( RequiredMethodsNotImplementedByClass => class_name => $class->name, + role_name => $role->name, + missing_methods => \@missing, + ); + } + } +} + +sub check_required_attributes { + +} + +sub apply_attributes { + my ($self, $role, $class) = @_; + + foreach my $attribute_name ($role->get_attribute_list) { + # it if it has one already + if ($class->has_attribute($attribute_name) && + # make sure we haven't seen this one already too + $class->get_attribute($attribute_name) != $role->get_attribute($attribute_name)) { + next; + } + else { + $class->add_attribute( + $role->get_attribute($attribute_name)->attribute_for_class + ); + } + } +} + +sub apply_methods { + my ( $self, $role, $class ) = @_; + + foreach my $method ( $role->_get_local_methods ) { + my $method_name = $method->name; + + next if $method->isa('Class::MOP::Method::Meta'); + + unless ( $self->is_method_excluded($method_name) ) { + + my $class_method = $class->get_method($method_name); + + next if $class_method && $class_method->body != $method->body; + + $class->add_method( + $method_name, + $method, + ); + } + + next unless $self->is_method_aliased($method_name); + + my $aliased_method_name = $self->get_method_aliases->{$method_name}; + + my $class_method = $class->get_method($aliased_method_name); + + if ( $class_method && $class_method->body != $method->body ) { + throw_exception( CannotCreateMethodAliasLocalMethodIsPresentInClass => aliased_method_name => $aliased_method_name, + method => $method, + role_name => $role->name, + class_name => $class->name, + ); + } + + $class->add_method( + $aliased_method_name, + $method, + ); + } + + # we must reset the cache here since + # we are just aliasing methods, otherwise + # the modifiers go wonky. + $class->reset_package_cache_flag; +} + +sub apply_override_method_modifiers { + my ($self, $role, $class) = @_; + foreach my $method_name ($role->get_method_modifier_list('override')) { + # it if it has one already then ... + if ($class->has_method($method_name)) { + next; + } + else { + # if this is not a role, then we need to + # find the original package of the method + # so that we can tell the class were to + # find the right super() method + my $method = $role->get_override_method_modifier($method_name); + my ($package) = Class::MOP::get_code_info($method); + # if it is a class, we just add it + $class->add_override_method_modifier($method_name, $method, $package); + } + } +} + +sub apply_method_modifiers { + my ($self, $modifier_type, $role, $class) = @_; + my $add = "add_${modifier_type}_method_modifier"; + my $get = "get_${modifier_type}_method_modifiers"; + foreach my $method_name ($role->get_method_modifier_list($modifier_type)) { + $class->$add( + $method_name, + $_ + ) foreach $role->$get($method_name); + } +} + +1; + +# ABSTRACT: Compose a role into a class + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Role::Application::ToClass - Compose a role into a class + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +=head2 METHODS + +=over 4 + +=item B<new> + +=item B<meta> + +=item B<apply> + +=item B<check_role_exclusions> + +=item B<check_required_methods> + +=item B<check_required_attributes> + +=item B<apply_attributes> + +=item B<apply_methods> + +=item B<apply_method_modifiers> + +=item B<apply_override_method_modifiers> + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Role/Application/ToInstance.pm b/lib/Moose/Meta/Role/Application/ToInstance.pm new file mode 100644 index 0000000..5e82c45 --- /dev/null +++ b/lib/Moose/Meta/Role/Application/ToInstance.pm @@ -0,0 +1,141 @@ +package Moose::Meta::Role::Application::ToInstance; +our $VERSION = '2.1405'; + +use strict; +use warnings; +use metaclass; + +use Scalar::Util 'blessed'; +use List::Util 1.33 'all'; + +use parent 'Moose::Meta::Role::Application'; + +__PACKAGE__->meta->add_attribute('rebless_params' => ( + reader => 'rebless_params', + default => sub { {} }, + Class::MOP::_definition_context(), +)); + +use constant _NEED_OVERLOAD_HACK_FOR_OBJECTS => $] < 5.008009; + +sub apply { + my ( $self, $role, $object, $args ) = @_; + + my $obj_meta = Class::MOP::class_of($object) || 'Moose::Meta::Class'; + + # This is a special case to handle the case where the object's metaclass + # is a Class::MOP::Class, but _not_ a Moose::Meta::Class (for example, + # when applying a role to a Moose::Meta::Attribute object). + $obj_meta = 'Moose::Meta::Class' + unless $obj_meta->isa('Moose::Meta::Class'); + + my $class = $obj_meta->create_anon_class( + superclasses => [ blessed($object) ], + roles => [ $role, keys(%$args) ? ($args) : () ], + cache => (all { $_ eq '-alias' || $_ eq '-excludes' } keys %$args), + ); + + $class->rebless_instance( $object, %{ $self->rebless_params } ); + + if ( _NEED_OVERLOAD_HACK_FOR_OBJECTS + && overload::Overloaded( ref $object ) ) { + + # need to use $_[2] here to apply to the object in the caller + _reset_amagic($_[2]); + } + + return $object; +} + +1; + +# ABSTRACT: Compose a role into an instance + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Role::Application::ToInstance - Compose a role into an instance + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +=head2 METHODS + +=over 4 + +=item B<new> + +=item B<meta> + +=item B<apply> + +=item B<rebless_params> + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Role/Application/ToRole.pm b/lib/Moose/Meta/Role/Application/ToRole.pm new file mode 100644 index 0000000..0d8af91 --- /dev/null +++ b/lib/Moose/Meta/Role/Application/ToRole.pm @@ -0,0 +1,283 @@ +package Moose::Meta::Role::Application::ToRole; +our $VERSION = '2.1405'; + +use strict; +use warnings; +use metaclass; + +use parent 'Moose::Meta::Role::Application'; + +use Moose::Util 'throw_exception'; + +sub apply { + my ($self, $role1, $role2) = @_; + $self->SUPER::apply($role1, $role2); + $role2->add_role($role1); +} + +sub check_role_exclusions { + my ($self, $role1, $role2) = @_; + if ( $role2->excludes_role($role1->name) ) { + throw_exception( ConflictDetectedInCheckRoleExclusions => role_name => $role2->name, + excluded_role_name => $role1->name, + ); + } + foreach my $excluded_role_name ($role1->get_excluded_roles_list) { + if ( $role2->does_role($excluded_role_name) ) { + throw_exception( RoleDoesTheExcludedRole => role_name => $role2->name, + excluded_role_name => $excluded_role_name, + second_role_name => $role1->name, + ); + } + $role2->add_excluded_roles($excluded_role_name); + } +} + +sub check_required_methods { + my ($self, $role1, $role2) = @_; + foreach my $required_method ($role1->get_required_method_list) { + my $required_method_name = $required_method->name; + + next if $self->is_aliased_method($required_method_name); + + $role2->add_required_methods($required_method) + unless $role2->find_method_by_name($required_method_name); + } +} + +sub check_required_attributes { + +} + +sub apply_attributes { + my ($self, $role1, $role2) = @_; + foreach my $attribute_name ($role1->get_attribute_list) { + # it if it has one already + if ($role2->has_attribute($attribute_name) && + # make sure we haven't seen this one already too + $role2->get_attribute($attribute_name) != $role1->get_attribute($attribute_name)) { + + my $role2_name = $role2->name; + + throw_exception( AttributeConflictInRoles => role_name => $role1->name, + second_role_name => $role2->name, + attribute_name => $attribute_name + ); + } + else { + $role2->add_attribute( + $role1->get_attribute($attribute_name)->clone + ); + } + } +} + +sub apply_methods { + my ( $self, $role1, $role2 ) = @_; + foreach my $method ( $role1->_get_local_methods ) { + + my $method_name = $method->name; + + next if $method->isa('Class::MOP::Method::Meta'); + + unless ( $self->is_method_excluded($method_name) ) { + + my $role2_method = $role2->get_method($method_name); + if ( $role2_method + && $role2_method->body != $method->body ) { + + # method conflicts between roles used to result in the method + # becoming a requirement but now are permitted just like + # for classes, hence no code in this branch anymore. + } + else { + $role2->add_method( + $method_name, + $method, + ); + } + } + + next unless $self->is_method_aliased($method_name); + + my $aliased_method_name = $self->get_method_aliases->{$method_name}; + + my $role2_method = $role2->get_method($aliased_method_name); + + if ( $role2_method + && $role2_method->body != $method->body ) { + + throw_exception( CannotCreateMethodAliasLocalMethodIsPresent => aliased_method_name => $aliased_method_name, + method => $method, + role_name => $role2->name, + role_being_applied_name => $role1->name, + ); + } + + $role2->add_method( + $aliased_method_name, + $role1->get_method($method_name) + ); + + if ( !$role2->has_method($method_name) ) { + $role2->add_required_methods($method_name) + unless $self->is_method_excluded($method_name); + } + } +} + +sub apply_override_method_modifiers { + my ($self, $role1, $role2) = @_; + foreach my $method_name ($role1->get_method_modifier_list('override')) { + # it if it has one already then ... + if ($role2->has_method($method_name)) { + # if it is being composed into another role + # we have a conflict here, because you cannot + # combine an overridden method with a locally + # defined one + throw_exception( OverrideConflictInComposition => role_name => $role2->name, + role_being_applied_name => $role1->name, + method_name => $method_name + ); + } + else { + # if we are a role, we need to make sure + # we don't have a conflict with the role + # we are composing into + if ($role2->has_override_method_modifier($method_name) && + $role1->get_override_method_modifier($method_name) != $role2->get_override_method_modifier($method_name)) { + + throw_exception( OverrideConflictInComposition => role_name => $role2->name, + role_being_applied_name => $role1->name, + method_name => $method_name, + two_overrides_found => 1 + ); + } + else { + # if there is no conflict, + # just add it to the role + $role2->add_override_method_modifier( + $method_name, + $role1->get_override_method_modifier($method_name) + ); + } + } + } +} + +sub apply_method_modifiers { + my ($self, $modifier_type, $role1, $role2) = @_; + my $add = "add_${modifier_type}_method_modifier"; + my $get = "get_${modifier_type}_method_modifiers"; + foreach my $method_name ($role1->get_method_modifier_list($modifier_type)) { + $role2->$add( + $method_name, + $_ + ) foreach $role1->$get($method_name); + } +} + +1; + +# ABSTRACT: Compose a role into another role + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Role::Application::ToRole - Compose a role into another role + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +=head2 METHODS + +=over 4 + +=item B<new> + +=item B<meta> + +=item B<apply> + +=item B<check_role_exclusions> + +=item B<check_required_methods> + +=item B<check_required_attributes> + +=item B<apply_attributes> + +=item B<apply_methods> + +=item B<apply_method_modifiers> + +=item B<apply_override_method_modifiers> + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Role/Attribute.pm b/lib/Moose/Meta/Role/Attribute.pm new file mode 100644 index 0000000..0c09550 --- /dev/null +++ b/lib/Moose/Meta/Role/Attribute.pm @@ -0,0 +1,263 @@ +package Moose::Meta::Role::Attribute; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use List::Util 1.33 'all'; +use Scalar::Util 'blessed', 'weaken'; + +use parent 'Moose::Meta::Mixin::AttributeCore', 'Class::MOP::Object'; + +use Moose::Util 'throw_exception'; + +__PACKAGE__->meta->add_attribute( + 'metaclass' => ( + reader => 'metaclass', + Class::MOP::_definition_context(), + ) +); + +__PACKAGE__->meta->add_attribute( + 'associated_role' => ( + reader => 'associated_role', + Class::MOP::_definition_context(), + ) +); + +__PACKAGE__->meta->add_attribute( + '_original_role' => ( + reader => '_original_role', + Class::MOP::_definition_context(), + ) +); + +__PACKAGE__->meta->add_attribute( + 'is' => ( + reader => 'is', + Class::MOP::_definition_context(), + ) +); + +__PACKAGE__->meta->add_attribute( + 'original_options' => ( + reader => 'original_options', + Class::MOP::_definition_context(), + ) +); + +sub new { + my ( $class, $name, %options ) = @_; + + (defined $name) + || throw_exception( MustProvideANameForTheAttribute => params => \%options, + class => $class + ); + + my $role = delete $options{_original_role}; + + return bless { + name => $name, + original_options => \%options, + _original_role => $role, + %options, + }, $class; +} + +sub attach_to_role { + my ( $self, $role ) = @_; + + ( blessed($role) && $role->isa('Moose::Meta::Role') ) + || throw_exception( MustPassAMooseMetaRoleInstanceOrSubclass => class => $self, + role => $role + ); + + weaken( $self->{'associated_role'} = $role ); +} + +sub original_role { + my $self = shift; + + return $self->_original_role || $self->associated_role; +} + +sub attribute_for_class { + my $self = shift; + + my $metaclass = $self->original_role->applied_attribute_metaclass; + + return $metaclass->interpolate_class_and_new( + $self->name => %{ $self->original_options } ); +} + +sub clone { + my $self = shift; + + my $role = $self->original_role; + + return ( ref $self )->new( + $self->name, + %{ $self->original_options }, + _original_role => $role, + ); +} + +sub is_same_as { + my $self = shift; + my $attr = shift; + + my $self_options = $self->original_options; + my $other_options = $attr->original_options; + + return 0 + unless ( join q{|}, sort keys %{$self_options} ) eq ( join q{|}, sort keys %{$other_options} ); + + for my $key ( keys %{$self_options} ) { + return 0 if defined $self_options->{$key} && ! defined $other_options->{$key}; + return 0 if ! defined $self_options->{$key} && defined $other_options->{$key}; + + next if all { ! defined } $self_options->{$key}, $other_options->{$key}; + + return 0 unless $self_options->{$key} eq $other_options->{$key}; + } + + return 1; +} + +1; + +# ABSTRACT: The Moose attribute metaclass for Roles + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Role::Attribute - The Moose attribute metaclass for Roles + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class implements the API for attributes in roles. Attributes in roles are +more like attribute prototypes than full blown attributes. While they are +introspectable, they have very little behavior. + +=head1 METHODS + +This class provides the following methods: + +=over 4 + +=item B<< Moose::Meta::Role::Attribute->new(...) >> + +This method accepts all the options that would be passed to the constructor +for L<Moose::Meta::Attribute>. + +=item B<< $attr->metaclass >> + +=item B<< $attr->is >> + +Returns the option as passed to the constructor. + +=item B<< $attr->associated_role >> + +Returns the L<Moose::Meta::Role> to which this attribute belongs, if any. + +=item B<< $attr->original_role >> + +Returns the L<Moose::Meta::Role> in which this attribute was first +defined. This may not be the same as the value of C<associated_role()> for +attributes in a composite role, or when one role consumes other roles. + +=item B<< $attr->original_options >> + +Returns a hash reference of options passed to the constructor. This is used +when creating a L<Moose::Meta::Attribute> object from this object. + +=item B<< $attr->attach_to_role($role) >> + +Attaches the attribute to the given L<Moose::Meta::Role>. + +=item B<< $attr->attribute_for_class($metaclass) >> + +Given an attribute metaclass name, this method calls C<< +$metaclass->interpolate_class_and_new >> to construct an attribute object +which can be added to a L<Moose::Meta::Class>. + +=item B<< $attr->clone >> + +Creates a new object identical to the object on which the method is called. + +=item B<< $attr->is_same_as($other_attr) >> + +Compares two role attributes and returns true if they are identical. + +=back + +In addition, this class implements all informational predicates implements by +L<Moose::Meta::Attribute> (and L<Class::MOP::Attribute>). + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Role/Composite.pm b/lib/Moose/Meta/Role/Composite.pm new file mode 100644 index 0000000..40e0dad --- /dev/null +++ b/lib/Moose/Meta/Role/Composite.pm @@ -0,0 +1,324 @@ +package Moose::Meta::Role::Composite; +our $VERSION = '2.1405'; + +use strict; +use warnings; +use metaclass; + +use Scalar::Util 'blessed'; +use Moose::Util 'throw_exception'; +use parent 'Moose::Meta::Role'; + +# NOTE: +# we need to override the ->name +# method from Class::MOP::Package +# since we don't have an actual +# package for this. +# - SL +__PACKAGE__->meta->add_attribute('name' => ( + reader => 'name', + Class::MOP::_definition_context(), +)); + +# NOTE: +# Again, since we don't have a real +# package to store our methods in, +# we use a HASH ref instead. +# - SL +__PACKAGE__->meta->add_attribute('_methods' => ( + reader => '_method_map', + default => sub { {} }, + Class::MOP::_definition_context(), +)); + +__PACKAGE__->meta->add_attribute('_overloads' => ( + reader => '_overload_map', + default => sub { {} }, + Class::MOP::_definition_context(), +)); + +__PACKAGE__->meta->add_attribute('_overload_fallback' => ( + accessor => '_overload_fallback', + Class::MOP::_definition_context(), +)); + +__PACKAGE__->meta->add_attribute( + 'application_role_summation_class', + reader => 'application_role_summation_class', + default => 'Moose::Meta::Role::Application::RoleSummation', + Class::MOP::_definition_context(), +); + +sub new { + my ($class, %params) = @_; + + # the roles param is required ... + foreach ( @{$params{roles}} ) { + unless ( $_->isa('Moose::Meta::Role') ) { + throw_exception( RolesListMustBeInstancesOfMooseMetaRole => params => \%params, + role => $_, + class => $class + ); + } + } + + my @composition_roles = map { + $_->composition_class_roles + } @{ $params{roles} }; + + if (@composition_roles) { + my $meta = Moose::Meta::Class->create_anon_class( + superclasses => [ $class ], + roles => [ @composition_roles ], + cache => 1, + ); + $class = $meta->name; + } + + # and the name is created from the + # roles if one has not been provided + $params{name} ||= (join "|" => map { $_->name } @{$params{roles}}); + $class->_new(\%params); +} + +# There's no such thing as an anonymous composite role since composites are an +# artifact of Moose's internals. However, a composite role that contains an +# anon role may _look_ like an anon role since $self->name =~ /$anon_key/ can +# return true if the first role in the composite is anonymous itself. +sub is_anon { 0 } + +# This is largely a copy of what's in Moose::Meta::Role (itself +# largely a copy of Class::MOP::Class). However, we can't actually +# call add_package_symbol, because there's no package into which to +# add the symbol. +sub add_method { + my ($self, $method_name, $method) = @_; + + unless ( defined $method_name && $method_name ) { + throw_exception( MustDefineAMethodName => instance => $self ); + } + + my $body; + if (blessed($method)) { + $body = $method->body; + if ($method->package_name ne $self->name) { + $method = $method->clone( + package_name => $self->name, + name => $method_name + ) if $method->can('clone'); + } + } + else { + $body = $method; + $method = $self->wrap_method_body( body => $body, name => $method_name ); + } + + $self->_method_map->{$method_name} = $method; +} + +sub get_method_list { + my $self = shift; + return keys %{ $self->_method_map }; +} + +sub _get_local_methods { + my $self = shift; + return values %{ $self->_method_map }; +} + +sub has_method { + my ($self, $method_name) = @_; + + return exists $self->_method_map->{$method_name}; +} + +sub get_method { + my ($self, $method_name) = @_; + + return $self->_method_map->{$method_name}; +} + +sub is_overloaded { + my ($self) = @_; + return keys %{ $self->_overload_map }; +} + +sub add_overloaded_operator { + my ( $self, $op_name, $overload ) = @_; + + unless ( defined $op_name && $op_name ) { + throw_exception( + 'MustDefineAnOverloadOperator', + instance => $self, + ); + } + + $self->_overload_map->{$op_name} = $overload; +} + +sub get_overload_fallback_value { + my ($self) = @_; + return $self->_overload_fallback; +} + +sub set_overload_fallback_value { + my $self = shift; + $self->_overload_fallback(shift); +} + +sub get_all_overloaded_operators { + my ( $self, $method_name ) = @_; + return values %{ $self->_overload_map }; +} + +sub apply_params { + my ($self, $role_params) = @_; + Moose::Util::_load_user_class($self->application_role_summation_class); + + $self->application_role_summation_class->new( + role_params => $role_params, + )->apply($self); + + return $self; +} + +sub reinitialize { + my ( $class, $old_meta, @args ) = @_; + + throw_exception( CannotInitializeMooseMetaRoleComposite => old_meta => $old_meta, + args => \@args, + role_composite => $class + ) + if !blessed $old_meta + || !$old_meta->isa('Moose::Meta::Role::Composite'); + + my %existing_classes = map { $_ => $old_meta->$_() } qw( + application_role_summation_class + ); + + return $old_meta->meta->clone_object( $old_meta, %existing_classes, @args ); +} + +1; + +# ABSTRACT: An object to represent the set of roles + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Role::Composite - An object to represent the set of roles + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +A composite is a role that consists of a set of two or more roles. + +The API of a composite role is almost identical to that of a regular +role. + +=head1 INHERITANCE + +C<Moose::Meta::Role::Composite> is a subclass of L<Moose::Meta::Role>. + +=head2 METHODS + +=over 4 + +=item B<< Moose::Meta::Role::Composite->new(%options) >> + +This returns a new composite role object. It accepts the same +options as its parent class, with a few changes: + +=over 8 + +=item * roles + +This option is an array reference containing a list of +L<Moose::Meta::Role> object. This is a required option. + +=item * name + +If a name is not given, one is generated from the roles provided. + +=item * apply_params(\%role_params) + +Creates a new RoleSummation role application with C<%role_params> and applies +the composite role to it. The RoleSummation role application class used is +determined by the composite role's C<application_role_summation_class> +attribute. + +=item * reinitialize($metaclass) + +Like C<< Class::MOP::Package->reinitialize >>, but doesn't allow passing a +string with the package name, as there is no real package for composite roles. + +=back + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Role/Method.pm b/lib/Moose/Meta/Role/Method.pm new file mode 100644 index 0000000..5dff6f4 --- /dev/null +++ b/lib/Moose/Meta/Role/Method.pm @@ -0,0 +1,101 @@ +package Moose::Meta::Role::Method; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use parent 'Moose::Meta::Method'; + +sub _make_compatible_with { + my $self = shift; + my ($other) = @_; + + # XXX: this is pretty gross. the issue here is blah blah blah + # see the comments in CMOP::Method::Meta and CMOP::Method::Wrapped + return $self unless $other->_is_compatible_with($self->_real_ref_name); + + return $self->SUPER::_make_compatible_with(@_); +} + +1; + +# ABSTRACT: A Moose Method metaclass for Roles + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Role::Method - A Moose Method metaclass for Roles + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This is primarily used to mark methods coming from a role +as being different. Right now it is nothing but a subclass +of L<Moose::Meta::Method>. + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Role/Method/Conflicting.pm b/lib/Moose/Meta/Role/Method/Conflicting.pm new file mode 100644 index 0000000..9d810fc --- /dev/null +++ b/lib/Moose/Meta/Role/Method/Conflicting.pm @@ -0,0 +1,139 @@ +package Moose::Meta::Role::Method::Conflicting; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Moose::Util; + +use parent 'Moose::Meta::Role::Method::Required'; + +__PACKAGE__->meta->add_attribute('roles' => ( + reader => 'roles', + required => 1, + Class::MOP::_definition_context(), +)); + +sub roles_as_english_list { + my $self = shift; + Moose::Util::english_list( map { q{'} . $_ . q{'} } @{ $self->roles } ); +} + +1; + +# ABSTRACT: A Moose metaclass for conflicting methods in Roles + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Role::Method::Conflicting - A Moose metaclass for conflicting methods in Roles + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +=head1 INHERITANCE + +C<Moose::Meta::Role::Method::Conflicting> is a subclass of +L<Moose::Meta::Role::Method::Required>. + +=head1 METHODS + +=over 4 + +=item B<< Moose::Meta::Role::Method::Conflicting->new(%options) >> + +This creates a new type constraint based on the provided C<%options>: + +=over 8 + +=item * name + +The method name. This is required. + +=item * roles + +The list of role names that generated the conflict. This is required. + +=back + +=item B<< $method->name >> + +Returns the conflicting method's name, as provided to the constructor. + +=item B<< $method->roles >> + +Returns the roles that generated this conflicting method, as provided to the +constructor. + +=item B<< $method->roles_as_english_list >> + +Returns the roles that generated this conflicting method as an English list. + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/Role/Method/Required.pm b/lib/Moose/Meta/Role/Method/Required.pm new file mode 100644 index 0000000..ebdd366 --- /dev/null +++ b/lib/Moose/Meta/Role/Method/Required.pm @@ -0,0 +1,129 @@ +package Moose::Meta::Role::Method::Required; +our $VERSION = '2.1405'; + +use strict; +use warnings; +use metaclass; + +use overload '""' => sub { shift->name }, # stringify to method name + fallback => 1; + +use parent 'Class::MOP::Object'; + +# This is not a Moose::Meta::Role::Method because it has no implementation, it +# is just a name + +__PACKAGE__->meta->add_attribute('name' => ( + reader => 'name', + required => 1, + Class::MOP::_definition_context(), +)); + +sub new { shift->_new(@_) } + +1; + +# ABSTRACT: A Moose metaclass for required methods in Roles + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::Role::Method::Required - A Moose metaclass for required methods in Roles + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +=head1 INHERITANCE + +C<Moose::Meta::Role::Method::Required> is a subclass of L<Class::MOP::Object>. +It is B<not> a subclass of C<Moose::Meta::Role::Method> since it does not +provide an implementation of the method. + +=head1 METHODS + +=over 4 + +=item B<< Moose::Meta::Role::Method::Required->new(%options) >> + +This creates a new type constraint based on the provided C<%options>: + +=over 8 + +=item * name + +The method name. This is required. + +=back + +=item B<< $method->name >> + +Returns the required method's name, as provided to the constructor. + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/TypeCoercion.pm b/lib/Moose/Meta/TypeCoercion.pm new file mode 100644 index 0000000..58317bc --- /dev/null +++ b/lib/Moose/Meta/TypeCoercion.pm @@ -0,0 +1,243 @@ +package Moose::Meta::TypeCoercion; +our $VERSION = '2.1405'; + +use strict; +use warnings; +use metaclass; + +use Moose::Meta::Attribute; +use Moose::Util::TypeConstraints (); + +use Moose::Util 'throw_exception'; + +__PACKAGE__->meta->add_attribute('type_coercion_map' => ( + reader => 'type_coercion_map', + default => sub { [] }, + Class::MOP::_definition_context(), +)); + +__PACKAGE__->meta->add_attribute( + Moose::Meta::Attribute->new('type_constraint' => ( + reader => 'type_constraint', + weak_ref => 1, + Class::MOP::_definition_context(), + )) +); + +# private accessor +__PACKAGE__->meta->add_attribute('compiled_type_coercion' => ( + accessor => '_compiled_type_coercion', + Class::MOP::_definition_context(), +)); + +sub new { + my $class = shift; + my $self = Class::MOP::class_of($class)->new_object(@_); + $self->compile_type_coercion; + return $self; +} + +sub compile_type_coercion { + my $self = shift; + my @coercion_map = @{$self->type_coercion_map}; + my @coercions; + while (@coercion_map) { + my ($constraint_name, $action) = splice(@coercion_map, 0, 2); + my $type_constraint = ref $constraint_name ? $constraint_name : Moose::Util::TypeConstraints::find_or_parse_type_constraint($constraint_name); + + unless ( defined $type_constraint ) { + throw_exception( CouldNotFindTypeConstraintToCoerceFrom => constraint_name => $constraint_name, + instance => $self + ); + } + + push @coercions => [ + $type_constraint->_compiled_type_constraint, + $action + ]; + } + $self->_compiled_type_coercion(sub { + my $thing = shift; + foreach my $coercion (@coercions) { + my ($constraint, $converter) = @$coercion; + if ($constraint->($thing)) { + local $_ = $thing; + return $converter->($thing); + } + } + return $thing; + }); +} + +sub has_coercion_for_type { + my ($self, $type_name) = @_; + my %coercion_map = @{$self->type_coercion_map}; + exists $coercion_map{$type_name} ? 1 : 0; +} + +sub add_type_coercions { + my ($self, @new_coercion_map) = @_; + + my $coercion_map = $self->type_coercion_map; + my %has_coercion = @$coercion_map; + + while (@new_coercion_map) { + my ($constraint_name, $action) = splice(@new_coercion_map, 0, 2); + + if ( exists $has_coercion{$constraint_name} ) { + throw_exception( CoercionAlreadyExists => constraint_name => $constraint_name, + instance => $self + ); + } + + push @{$coercion_map} => ($constraint_name, $action); + } + + # and re-compile ... + $self->compile_type_coercion; +} + +sub coerce { $_[0]->_compiled_type_coercion->($_[1]) } + + +1; + +# ABSTRACT: The Moose Type Coercion metaclass + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::TypeCoercion - The Moose Type Coercion metaclass + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +A type coercion object is basically a mapping of one or more type +constraints and the associated coercions subroutines. + +It's unlikely that you will need to instantiate an object of this +class directly, as it's part of the deep internals of Moose. + +=head1 METHODS + +=over 4 + +=item B<< Moose::Meta::TypeCoercion->new(%options) >> + +Creates a new type coercion object, based on the options provided. + +=over 8 + +=item * type_constraint + +This is the L<Moose::Meta::TypeConstraint> object for the type that is +being coerced I<to>. + +=back + +=item B<< $coercion->type_coercion_map >> + +This returns the map of type constraints to coercions as an array +reference. The values of the array alternate between type names and +subroutine references which implement the coercion. + +The value is an array reference because coercions are tried in the +order they are added. + +=item B<< $coercion->type_constraint >> + +This returns the L<Moose::Meta::TypeConstraint> that was passed to the +constructor. + +=item B<< $coercion->has_coercion_for_type($type_name) >> + +Returns true if the coercion can coerce the named type. + +=item B<< $coercion->add_type_coercions( $type_name => $sub, ... ) >> + +This method takes a list of type names and subroutine references. If +the coercion already has a mapping for a given type, it throws an +exception. + +Coercions are actually + +=item B<< $coercion->coerce($value) >> + +This method takes a value and applies the first valid coercion it +finds. + +This means that if the value could belong to more than type in the +coercion object, the first coercion added is used. + +=item B<< Moose::Meta::TypeCoercion->meta >> + +This will return a L<Class::MOP::Class> instance for this class. + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/TypeCoercion/Union.pm b/lib/Moose/Meta/TypeCoercion/Union.pm new file mode 100644 index 0000000..5ef179d --- /dev/null +++ b/lib/Moose/Meta/TypeCoercion/Union.pm @@ -0,0 +1,145 @@ +package Moose::Meta::TypeCoercion::Union; +our $VERSION = '2.1405'; + +use strict; +use warnings; +use metaclass; + +use Scalar::Util 'blessed'; + +use parent 'Moose::Meta::TypeCoercion'; + +use Moose::Util 'throw_exception'; + +sub compile_type_coercion { + my $self = shift; + my $type_constraint = $self->type_constraint; + + (blessed $type_constraint && $type_constraint->isa('Moose::Meta::TypeConstraint::Union')) + || throw_exception( NeedsTypeConstraintUnionForTypeCoercionUnion => type_coercion_union_object => $self, + type_name => $type_constraint->name + ); + + $self->_compiled_type_coercion( + sub { + my $value = shift; + + foreach my $type ( grep { $_->has_coercion } + @{ $type_constraint->type_constraints } ) { + my $temp = $type->coerce($value); + return $temp if $type_constraint->check($temp); + } + + return $value; + } + ); +} + +sub has_coercion_for_type { 0 } + +sub add_type_coercions { + my $self = shift; + throw_exception( CannotAddAdditionalTypeCoercionsToUnion => type_coercion_union_object => $self ); +} + +1; + +# ABSTRACT: The Moose Type Coercion metaclass for Unions + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::TypeCoercion::Union - The Moose Type Coercion metaclass for Unions + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This is a subclass of L<Moose::Meta::TypeCoercion> that is used for +L<Moose::Meta::TypeConstraint::Union> objects. + +=head1 METHODS + +=over 4 + +=item B<< $coercion->has_coercion_for_type >> + +This method always returns false. + +=item B<< $coercion->add_type_coercions >> + +This method always throws an error. You cannot add coercions to a +union type coercion. + +=item B<< $coercion->coerce($value) >> + +This method will coerce by trying the coercions for each type in the +union. + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/TypeConstraint.pm b/lib/Moose/Meta/TypeConstraint.pm new file mode 100644 index 0000000..e943eec --- /dev/null +++ b/lib/Moose/Meta/TypeConstraint.pm @@ -0,0 +1,604 @@ +package Moose::Meta::TypeConstraint; +our $VERSION = '2.1405'; + +use strict; +use warnings; +use metaclass; + +use overload '0+' => sub { refaddr(shift) }, # id an object + '""' => sub { shift->name }, # stringify to tc name + bool => sub { 1 }, + fallback => 1; + +use Eval::Closure; +use Scalar::Util qw(refaddr); +use Sub::Name qw(subname); +use Try::Tiny; + +use base 'Class::MOP::Object'; + +use Moose::Util 'throw_exception'; + +__PACKAGE__->meta->add_attribute('name' => ( + reader => 'name', + Class::MOP::_definition_context(), +)); +__PACKAGE__->meta->add_attribute('parent' => ( + reader => 'parent', + predicate => 'has_parent', + Class::MOP::_definition_context(), +)); + +my $null_constraint = sub { 1 }; +__PACKAGE__->meta->add_attribute('constraint' => ( + reader => 'constraint', + writer => '_set_constraint', + default => sub { $null_constraint }, + Class::MOP::_definition_context(), +)); + +__PACKAGE__->meta->add_attribute('message' => ( + accessor => 'message', + predicate => 'has_message', + Class::MOP::_definition_context(), +)); + +__PACKAGE__->meta->add_attribute('_default_message' => ( + accessor => '_default_message', + Class::MOP::_definition_context(), +)); + +# can't make this a default because it has to close over the type name, and +# cmop attributes don't have lazy +my $_default_message_generator = sub { + my $name = shift; + sub { + my $value = shift; + # have to load it late like this, since it uses Moose itself + my $can_partialdump = try { + # versions prior to 0.14 had a potential infinite loop bug + require Devel::PartialDump; + Devel::PartialDump->VERSION(0.14); + 1; + }; + if ($can_partialdump) { + $value = Devel::PartialDump->new->dump($value); + } + else { + $value = (defined $value ? overload::StrVal($value) : 'undef'); + } + return "Validation failed for '" . $name . "' with value $value"; + } +}; +__PACKAGE__->meta->add_attribute('coercion' => ( + accessor => 'coercion', + predicate => 'has_coercion', + Class::MOP::_definition_context(), +)); + +__PACKAGE__->meta->add_attribute('inlined' => ( + init_arg => 'inlined', + accessor => 'inlined', + predicate => '_has_inlined_type_constraint', + Class::MOP::_definition_context(), +)); + +__PACKAGE__->meta->add_attribute('inline_environment' => ( + init_arg => 'inline_environment', + accessor => '_inline_environment', + default => sub { {} }, + Class::MOP::_definition_context(), +)); + +sub parents { + my $self = shift; + $self->parent; +} + +# private accessors + +__PACKAGE__->meta->add_attribute('compiled_type_constraint' => ( + accessor => '_compiled_type_constraint', + predicate => '_has_compiled_type_constraint', + Class::MOP::_definition_context(), +)); + +__PACKAGE__->meta->add_attribute('package_defined_in' => ( + accessor => '_package_defined_in', + Class::MOP::_definition_context(), +)); + +sub new { + my $class = shift; + my ($first, @rest) = @_; + my %args = ref $first ? %$first : $first ? ($first, @rest) : (); + $args{name} = $args{name} ? "$args{name}" : "__ANON__"; + + if ( exists $args{message} + && (!ref($args{message}) || ref($args{message}) ne 'CODE') ) { + throw_exception( MessageParameterMustBeCodeRef => params => \%args, + class => $class + ); + } + + my $self = $class->_new(%args); + $self->compile_type_constraint() + unless $self->_has_compiled_type_constraint; + $self->_default_message($_default_message_generator->($self->name)) + unless $self->has_message; + return $self; +} + + + +sub coerce { + my $self = shift; + + my $coercion = $self->coercion; + + unless ($coercion) { + throw_exception( CoercingWithoutCoercions => type_name => $self->name ); + } + + return $_[0] if $self->check($_[0]); + + return $coercion->coerce(@_); +} + +sub assert_coerce { + my $self = shift; + + my $result = $self->coerce(@_); + + $self->assert_valid($result); + + return $result; +} + +sub check { + my ($self, @args) = @_; + my $constraint_subref = $self->_compiled_type_constraint; + return $constraint_subref->(@args) ? 1 : undef; +} + +sub validate { + my ($self, $value) = @_; + if ($self->_compiled_type_constraint->($value)) { + return undef; + } + else { + $self->get_message($value); + } +} + +sub can_be_inlined { + my $self = shift; + + if ( $self->has_parent && $self->constraint == $null_constraint ) { + return $self->parent->can_be_inlined; + } + + return $self->_has_inlined_type_constraint; +} + +sub _inline_check { + my $self = shift; + + unless ( $self->can_be_inlined ) { + throw_exception( CannotInlineTypeConstraintCheck => type_name => $self->name ); + } + + if ( $self->has_parent && $self->constraint == $null_constraint ) { + return $self->parent->_inline_check(@_); + } + + return '( do { ' . $self->inlined->( $self, @_ ) . ' } )'; +} + +sub inline_environment { + my $self = shift; + + if ( $self->has_parent && $self->constraint == $null_constraint ) { + return $self->parent->inline_environment; + } + + return $self->_inline_environment; +} + +sub assert_valid { + my ( $self, $value ) = @_; + + return 1 if $self->check($value); + + throw_exception( + 'ValidationFailedForTypeConstraint', + type => $self, + value => $value + ); +} + +sub get_message { + my ($self, $value) = @_; + my $msg = $self->has_message + ? $self->message + : $self->_default_message; + local $_ = $value; + return $msg->($value); +} + +## type predicates ... + +sub equals { + my ( $self, $type_or_name ) = @_; + + my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return; + + return 1 if $self == $other; + + return unless $self->constraint == $other->constraint; + + if ( $self->has_parent ) { + return unless $other->has_parent; + return unless $self->parent->equals( $other->parent ); + } else { + return if $other->has_parent; + } + + return; +} + +sub is_a_type_of { + my ($self, $type_or_name) = @_; + + my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return; + + ($self->equals($type) || $self->is_subtype_of($type)); +} + +sub is_subtype_of { + my ($self, $type_or_name) = @_; + + my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return; + + my $current = $self; + + while (my $parent = $current->parent) { + return 1 if $parent->equals($type); + $current = $parent; + } + + return 0; +} + +## compiling the type constraint + +sub compile_type_constraint { + my $self = shift; + $self->_compiled_type_constraint($self->_actually_compile_type_constraint); +} + +## type compilers ... + +sub _actually_compile_type_constraint { + my $self = shift; + + if ( $self->can_be_inlined ) { + return eval_closure( + source => 'sub { ' . $self->_inline_check('$_[0]') . ' }', + environment => $self->inline_environment, + ); + } + + my $check = $self->constraint; + unless ( defined $check ) { + throw_exception( NoConstraintCheckForTypeConstraint => type_name => $self->name ); + } + + return $self->_compile_subtype($check) + if $self->has_parent; + + return $self->_compile_type($check); +} + +sub _compile_subtype { + my ($self, $check) = @_; + + # gather all the parent constraints in order + my @parents; + foreach my $parent ($self->_collect_all_parents) { + push @parents => $parent->constraint; + } + + @parents = grep { $_ != $null_constraint } reverse @parents; + + unless ( @parents ) { + return $self->_compile_type($check); + } else { + # general case, check all the constraints, from the first parent to ourselves + my @checks = @parents; + push @checks, $check if $check != $null_constraint; + return subname($self->name => sub { + my (@args) = @_; + local $_ = $args[0]; + foreach my $check (@checks) { + return undef unless $check->(@args); + } + return 1; + }); + } +} + +sub _compile_type { + my ($self, $check) = @_; + + return $check if $check == $null_constraint; # Item, Any + + return subname($self->name => sub { + my (@args) = @_; + local $_ = $args[0]; + $check->(@args); + }); +} + +## other utils ... + +sub _collect_all_parents { + my $self = shift; + my @parents; + my $current = $self->parent; + while (defined $current) { + push @parents => $current; + $current = $current->parent; + } + return @parents; +} + +sub create_child_type { + my ($self, %opts) = @_; + my $class = ref $self; + return $class->new(%opts, parent => $self); +} + +1; + +# ABSTRACT: The Moose Type Constraint metaclass + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::TypeConstraint - The Moose Type Constraint metaclass + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class represents a single type constraint. Moose's built-in type +constraints, as well as constraints you define, are all stored in a +L<Moose::Meta::TypeConstraint::Registry> object as objects of this +class. + +=head1 INHERITANCE + +C<Moose::Meta::TypeConstraint> is a subclass of L<Class::MOP::Object>. + +=head1 METHODS + +=over 4 + +=item B<< Moose::Meta::TypeConstraint->new(%options) >> + +This creates a new type constraint based on the provided C<%options>: + +=over 8 + +=item * name + +The constraint name. If a name is not provided, it will be set to +"__ANON__". + +=item * parent + +A C<Moose::Meta::TypeConstraint> object which is the parent type for +the type being created. This is optional. + +=item * constraint + +This is the subroutine reference that implements the actual constraint +check. This defaults to a subroutine which always returns true. + +=item * message + +A subroutine reference which is used to generate an error message when +the constraint fails. This is optional. + +=item * coercion + +A L<Moose::Meta::TypeCoercion> object representing the coercions to +the type. This is optional. + +=item * inlined + +A subroutine which returns a string suitable for inlining this type +constraint. It will be called as a method on the type constraint object, and +will receive a single additional parameter, a variable name to be tested +(usually C<"$_"> or C<"$_[0]">. + +This is optional. + +=item * inline_environment + +A hash reference of variables to close over. The keys are variables names, and +the values are I<references> to the variables. + +=back + +=item B<< $constraint->equals($type_name_or_object) >> + +Returns true if the supplied name or type object is the same as the +current type. + +=item B<< $constraint->is_subtype_of($type_name_or_object) >> + +Returns true if the supplied name or type object is a parent of the +current type. + +=item B<< $constraint->is_a_type_of($type_name_or_object) >> + +Returns true if the given type is the same as the current type, or is +a parent of the current type. This is a shortcut for checking +C<equals> and C<is_subtype_of>. + +=item B<< $constraint->coerce($value) >> + +This will attempt to coerce the value to the type. If the type does not +have any defined coercions this will throw an error. + +If no coercion can produce a value matching C<$constraint>, the original +value is returned. + +=item B<< $constraint->assert_coerce($value) >> + +This method behaves just like C<coerce>, but if the result is not valid +according to C<$constraint>, an error is thrown. + +=item B<< $constraint->check($value) >> + +Returns true if the given value passes the constraint for the type. + +=item B<< $constraint->validate($value) >> + +This is similar to C<check>. However, if the type I<is valid> then the +method returns an explicit C<undef>. If the type is not valid, we call +C<< $self->get_message($value) >> internally to generate an error +message. + +=item B<< $constraint->assert_valid($value) >> + +Like C<check> and C<validate>, this method checks whether C<$value> is +valid under the constraint. If it is, it will return true. If it is not, +an exception will be thrown with the results of +C<< $self->get_message($value) >>. + +=item B<< $constraint->name >> + +Returns the type's name, as provided to the constructor. + +=item B<< $constraint->parent >> + +Returns the type's parent, as provided to the constructor, if any. + +=item B<< $constraint->has_parent >> + +Returns true if the type has a parent type. + +=item B<< $constraint->parents >> + +Returns all of the types parents as an list of type constraint objects. + +=item B<< $constraint->constraint >> + +Returns the type's constraint, as provided to the constructor. + +=item B<< $constraint->get_message($value) >> + +This generates a method for the given value. If the type does not have +an explicit message, we generate a default message. + +=item B<< $constraint->has_message >> + +Returns true if the type has a message. + +=item B<< $constraint->message >> + +Returns the type's message as a subroutine reference. + +=item B<< $constraint->coercion >> + +Returns the type's L<Moose::Meta::TypeCoercion> object, if one +exists. + +=item B<< $constraint->has_coercion >> + +Returns true if the type has a coercion. + +=item B<< $constraint->can_be_inlined >> + +Returns true if this type constraint can be inlined. A type constraint which +subtypes an inlinable constraint and does not add an additional constraint +"inherits" its parent type's inlining. + +=item B<< $constraint->create_child_type(%options) >> + +This returns a new type constraint of the same class using the +provided C<%options>. The C<parent> option will be the current type. + +This method exists so that subclasses of this class can override this +behavior and change how child types are created. + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/TypeConstraint/Class.pm b/lib/Moose/Meta/TypeConstraint/Class.pm new file mode 100644 index 0000000..2f5e5c3 --- /dev/null +++ b/lib/Moose/Meta/TypeConstraint/Class.pm @@ -0,0 +1,265 @@ +package Moose::Meta::TypeConstraint::Class; +our $VERSION = '2.1405'; + +use strict; +use warnings; +use metaclass; + +use B; +use Scalar::Util (); +use Moose::Util::TypeConstraints (); + +use parent 'Moose::Meta::TypeConstraint'; + +__PACKAGE__->meta->add_attribute('class' => ( + reader => 'class', + Class::MOP::_definition_context(), +)); + +my $inliner = sub { + my $self = shift; + my $val = shift; + + return 'Scalar::Util::blessed(' . $val . ')' + . ' && ' . $val . '->isa(' . B::perlstring($self->class) . ')'; +}; + +sub new { + my ( $class, %args ) = @_; + + $args{parent} + = Moose::Util::TypeConstraints::find_type_constraint('Object'); + + my $class_name = $args{class}; + $args{constraint} = sub { $_[0]->isa($class_name) }; + + $args{inlined} = $inliner; + + my $self = $class->SUPER::new( \%args ); + + $self->compile_type_constraint(); + + return $self; +} + +sub parents { + my $self = shift; + return ( + $self->parent, + map { + # FIXME find_type_constraint might find a TC named after the class but that isn't really it + # I did this anyway since it's a convention that preceded TypeConstraint::Class, and it should DWIM + # if anybody thinks this problematic please discuss on IRC. + # a possible fix is to add by attr indexing to the type registry to find types of a certain property + # regardless of their name + Moose::Util::TypeConstraints::find_type_constraint($_) + || + __PACKAGE__->new( class => $_, name => "__ANON__" ) + } Class::MOP::class_of($self->class)->superclasses, + ); +} + +sub equals { + my ( $self, $type_or_name ) = @_; + + my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name); + + if (!defined($other)) { + if (!ref($type_or_name)) { + return $self->class eq $type_or_name; + } + return; + } + + return unless $other->isa(__PACKAGE__); + + return $self->class eq $other->class; +} + +sub is_a_type_of { + my ($self, $type_or_name) = @_; + + ($self->equals($type_or_name) || $self->is_subtype_of($type_or_name)); +} + +sub is_subtype_of { + my ($self, $type_or_name_or_class ) = @_; + + my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name_or_class); + + if ( not defined $type ) { + if ( not ref $type_or_name_or_class ) { + # it might be a class + my $class = $self->class; + return 1 if $class ne $type_or_name_or_class + && $class->isa( $type_or_name_or_class ); + } + return; + } + + if ( $type->isa(__PACKAGE__) && $type->class ne $self->class) { + # if $type_or_name_or_class isn't a class, it might be the TC name of another ::Class type + # or it could also just be a type object in this branch + return $self->class->isa( $type->class ); + } else { + # the only other thing we are a subtype of is Object + $self->SUPER::is_subtype_of($type); + } +} + +# This is a bit counter-intuitive, but a child type of a Class type +# constraint is not itself a Class type constraint (it has no class +# attribute). This whole create_child_type thing needs some changing +# though, probably making MMC->new a factory or something. +sub create_child_type { + my ($self, @args) = @_; + return Moose::Meta::TypeConstraint->new(@args, parent => $self); +} + +sub get_message { + my $self = shift; + my ($value) = @_; + + if ($self->has_message) { + return $self->SUPER::get_message(@_); + } + + $value = (defined $value ? overload::StrVal($value) : 'undef'); + return "Validation failed for '" . $self->name . "' with value $value (not isa " . $self->class . ")"; +} + +1; + +# ABSTRACT: Class/TypeConstraint parallel hierarchy + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::TypeConstraint::Class - Class/TypeConstraint parallel hierarchy + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class represents type constraints for a class. + +=head1 INHERITANCE + +C<Moose::Meta::TypeConstraint::Class> is a subclass of +L<Moose::Meta::TypeConstraint>. + +=head1 METHODS + +=over 4 + +=item B<< Moose::Meta::TypeConstraint::Class->new(%options) >> + +This creates a new class type constraint based on the given +C<%options>. + +It takes the same options as its parent, with two exceptions. First, +it requires an additional option, C<class>, which is name of the +constraint's class. Second, it automatically sets the parent to the +C<Object> type. + +The constructor also overrides the hand optimized type constraint with +one it creates internally. + +=item B<< $constraint->class >> + +Returns the class name associated with the constraint. + +=item B<< $constraint->parents >> + +Returns all the type's parent types, corresponding to its parent +classes. + +=item B<< $constraint->is_subtype_of($type_name_or_object) >> + +If the given type is also a class type, then this checks that the +type's class is a subclass of the other type's class. + +Otherwise it falls back to the implementation in +L<Moose::Meta::TypeConstraint>. + +=item B<< $constraint->create_child_type(%options) >> + +This returns a new L<Moose::Meta::TypeConstraint> object with the type +as its parent. + +Note that it does I<not> return a +C<Moose::Meta::TypeConstraint::Class> object! + +=item B<< $constraint->get_message($value) >> + +This is the same as L<Moose::Meta::TypeConstraint/get_message> except +that it explicitly says C<isa> was checked. This is to help users deal +with accidentally autovivified type constraints. + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/TypeConstraint/DuckType.pm b/lib/Moose/Meta/TypeConstraint/DuckType.pm new file mode 100644 index 0000000..7304f35 --- /dev/null +++ b/lib/Moose/Meta/TypeConstraint/DuckType.pm @@ -0,0 +1,221 @@ +package Moose::Meta::TypeConstraint::DuckType; +our $VERSION = '2.1405'; + +use strict; +use warnings; +use metaclass; + +use B; +use Scalar::Util 'blessed'; +use List::Util 1.33 qw(all); +use Moose::Util 'english_list'; + +use Moose::Util::TypeConstraints (); + +use parent 'Moose::Meta::TypeConstraint'; + +__PACKAGE__->meta->add_attribute('methods' => ( + accessor => 'methods', + Class::MOP::_definition_context(), +)); + +my $inliner = sub { + my $self = shift; + my $val = shift; + + return $self->parent->_inline_check($val) + . ' && do {' . "\n" + . 'my $val = ' . $val . ';' . "\n" + . '&List::Util::all(' . "\n" + . 'sub { $val->can($_) },' . "\n" + . join(', ', map { B::perlstring($_) } @{ $self->methods }) + . ');' . "\n" + . '}'; +}; + +sub new { + my ( $class, %args ) = @_; + + $args{parent} + = Moose::Util::TypeConstraints::find_type_constraint('Object'); + + my @methods = @{ $args{methods} }; + $args{constraint} = sub { + my $val = $_[0]; + return all { $val->can($_) } @methods; + }; + + $args{inlined} = $inliner; + + my $self = $class->SUPER::new(\%args); + + $self->compile_type_constraint() + unless $self->_has_compiled_type_constraint; + + return $self; +} + +sub equals { + my ( $self, $type_or_name ) = @_; + + my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name); + + return unless $other->isa(__PACKAGE__); + + my @self_methods = sort @{ $self->methods }; + my @other_methods = sort @{ $other->methods }; + + return unless @self_methods == @other_methods; + + while ( @self_methods ) { + my $method = shift @self_methods; + my $other_method = shift @other_methods; + + return unless $method eq $other_method; + } + + return 1; +} + +sub create_child_type { + my ($self, @args) = @_; + return Moose::Meta::TypeConstraint->new(@args, parent => $self); +} + +sub get_message { + my $self = shift; + my ($value) = @_; + + if ($self->has_message) { + return $self->SUPER::get_message(@_); + } + + return $self->SUPER::get_message($value) unless blessed($value); + + my @methods = grep { !$value->can($_) } @{ $self->methods }; + my $class = blessed $value; + $class ||= $value; + + return $class + . " is missing methods " + . english_list(map { "'$_'" } @methods); +} + +1; + +# ABSTRACT: Type constraint for duck typing + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::TypeConstraint::DuckType - Type constraint for duck typing + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class represents type constraints based on an enumerated list of +required methods. + +=head1 INHERITANCE + +C<Moose::Meta::TypeConstraint::DuckType> is a subclass of +L<Moose::Meta::TypeConstraint>. + +=head1 METHODS + +=over 4 + +=item B<< Moose::Meta::TypeConstraint::DuckType->new(%options) >> + +This creates a new duck type constraint based on the given +C<%options>. + +It takes the same options as its parent, with several +exceptions. First, it requires an additional option, C<methods>. This +should be an array reference containing a list of required method +names. Second, it automatically sets the parent to the C<Object> type. + +Finally, it ignores any provided C<constraint> option. The constraint +is generated automatically based on the provided C<methods>. + +=item B<< $constraint->methods >> + +Returns the array reference of required methods provided to the +constructor. + +=item B<< $constraint->create_child_type >> + +This returns a new L<Moose::Meta::TypeConstraint> object with the type +as its parent. + +Note that it does I<not> return a C<Moose::Meta::TypeConstraint::DuckType> +object! + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/TypeConstraint/Enum.pm b/lib/Moose/Meta/TypeConstraint/Enum.pm new file mode 100644 index 0000000..9e1204d --- /dev/null +++ b/lib/Moose/Meta/TypeConstraint/Enum.pm @@ -0,0 +1,230 @@ +package Moose::Meta::TypeConstraint::Enum; +our $VERSION = '2.1405'; + +use strict; +use warnings; +use metaclass; + +use B; +use Moose::Util::TypeConstraints (); + +use parent 'Moose::Meta::TypeConstraint'; + +use Moose::Util 'throw_exception'; + +__PACKAGE__->meta->add_attribute('values' => ( + accessor => 'values', + Class::MOP::_definition_context(), +)); + +__PACKAGE__->meta->add_attribute('_inline_var_name' => ( + accessor => '_inline_var_name', + Class::MOP::_definition_context(), +)); + +my $inliner = sub { + my $self = shift; + my $val = shift; + + return 'defined(' . $val . ') ' + . '&& !ref(' . $val . ') ' + . '&& $' . $self->_inline_var_name . '{' . $val . '}'; +}; + +my $var_suffix = 0; + +sub new { + my ( $class, %args ) = @_; + + $args{parent} = Moose::Util::TypeConstraints::find_type_constraint('Str'); + $args{inlined} = $inliner; + + if ( scalar @{ $args{values} } < 1 ) { + throw_exception( MustHaveAtLeastOneValueToEnumerate => params => \%args, + class => $class + ); + } + + for (@{ $args{values} }) { + if (!defined($_)) { + throw_exception( EnumValuesMustBeString => params => \%args, + class => $class, + value => $_ + ); + } + elsif (ref($_)) { + throw_exception( EnumValuesMustBeString => params => \%args, + class => $class, + value => $_ + ); + } + } + + my %values = map { $_ => 1 } @{ $args{values} }; + $args{constraint} = sub { $values{ $_[0] } }; + + my $var_name = 'enums' . $var_suffix++;; + $args{_inline_var_name} = $var_name; + $args{inline_environment} = { '%' . $var_name => \%values }; + + my $self = $class->SUPER::new(\%args); + + $self->compile_type_constraint() + unless $self->_has_compiled_type_constraint; + + return $self; +} + +sub equals { + my ( $self, $type_or_name ) = @_; + + my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name); + + return unless $other->isa(__PACKAGE__); + + my @self_values = sort @{ $self->values }; + my @other_values = sort @{ $other->values }; + + return unless @self_values == @other_values; + + while ( @self_values ) { + my $value = shift @self_values; + my $other_value = shift @other_values; + + return unless $value eq $other_value; + } + + return 1; +} + +sub constraint { + my $self = shift; + + my %values = map { $_ => undef } @{ $self->values }; + + return sub { exists $values{$_[0]} }; +} + +sub create_child_type { + my ($self, @args) = @_; + return Moose::Meta::TypeConstraint->new(@args, parent => $self); +} + +1; + +# ABSTRACT: Type constraint for enumerated values. + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::TypeConstraint::Enum - Type constraint for enumerated values. + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class represents type constraints based on an enumerated list of +acceptable values. + +=head1 INHERITANCE + +C<Moose::Meta::TypeConstraint::Enum> is a subclass of +L<Moose::Meta::TypeConstraint>. + +=head1 METHODS + +=over 4 + +=item B<< Moose::Meta::TypeConstraint::Enum->new(%options) >> + +This creates a new enum type constraint based on the given +C<%options>. + +It takes the same options as its parent, with several +exceptions. First, it requires an additional option, C<values>. This +should be an array reference containing a list of valid string +values. Second, it automatically sets the parent to the C<Str> type. + +Finally, it ignores any provided C<constraint> option. The constraint +is generated automatically based on the provided C<values>. + +=item B<< $constraint->values >> + +Returns the array reference of acceptable values provided to the +constructor. + +=item B<< $constraint->create_child_type >> + +This returns a new L<Moose::Meta::TypeConstraint> object with the type +as its parent. + +Note that it does I<not> return a C<Moose::Meta::TypeConstraint::Enum> +object! + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/TypeConstraint/Parameterizable.pm b/lib/Moose/Meta/TypeConstraint/Parameterizable.pm new file mode 100644 index 0000000..250e4e6 --- /dev/null +++ b/lib/Moose/Meta/TypeConstraint/Parameterizable.pm @@ -0,0 +1,200 @@ +package Moose::Meta::TypeConstraint::Parameterizable; +our $VERSION = '2.1405'; + +use strict; +use warnings; +use metaclass; + +use parent 'Moose::Meta::TypeConstraint'; +use Moose::Meta::TypeConstraint::Parameterized; +use Moose::Util::TypeConstraints (); + +use Moose::Util 'throw_exception'; + +use Carp 'confess'; + +__PACKAGE__->meta->add_attribute('constraint_generator' => ( + accessor => 'constraint_generator', + predicate => 'has_constraint_generator', + Class::MOP::_definition_context(), +)); + +__PACKAGE__->meta->add_attribute('inline_generator' => ( + accessor => 'inline_generator', + predicate => 'has_inline_generator', + Class::MOP::_definition_context(), +)); + +sub generate_constraint_for { + my ($self, $type) = @_; + + return unless $self->has_constraint_generator; + + return $self->constraint_generator->($type->type_parameter) + if $type->is_subtype_of($self->name); + + return $self->_can_coerce_constraint_from($type) + if $self->has_coercion + && $self->coercion->has_coercion_for_type($type->parent->name); + + return; +} + +sub _can_coerce_constraint_from { + my ($self, $type) = @_; + my $coercion = $self->coercion; + my $constraint = $self->constraint_generator->($type->type_parameter); + return sub { + local $_ = $coercion->coerce($_); + $constraint->(@_); + }; +} + +sub generate_inline_for { + my ($self, $type, $val) = @_; + + throw_exception( CannotGenerateInlineConstraint => parameterizable_type_object_name => $self->name, + type_name => $type->name, + value => $val, + ) + unless $self->has_inline_generator; + + return '( do { ' . $self->inline_generator->( $self, $type, $val ) . ' } )'; +} + +sub _parse_type_parameter { + my ($self, $type_parameter) = @_; + return Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($type_parameter); +} + +sub parameterize { + my ($self, $type_parameter) = @_; + + my $contained_tc = $self->_parse_type_parameter($type_parameter); + + ## The type parameter should be a subtype of the parent's type parameter + ## if there is one. + + if(my $parent = $self->parent) { + if($parent->can('type_parameter')) { + unless ( $contained_tc->is_a_type_of($parent->type_parameter) ) { + throw_exception( ParameterIsNotSubtypeOfParent => type_parameter => $type_parameter, + type_name => $self->name, + ); + } + } + } + + if ( $contained_tc->isa('Moose::Meta::TypeConstraint') ) { + my $tc_name = $self->name . '[' . $contained_tc->name . ']'; + return Moose::Meta::TypeConstraint::Parameterized->new( + name => $tc_name, + parent => $self, + type_parameter => $contained_tc, + parameterized_from => $self, + ); + } + else { + confess("The type parameter must be a Moose meta type"); + } +} + + +1; + +# ABSTRACT: Type constraints which can take a parameter (ArrayRef) + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::TypeConstraint::Parameterizable - Type constraints which can take a parameter (ArrayRef) + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class represents a parameterizable type constraint. This is a +type constraint like C<ArrayRef> or C<HashRef>, that can be +parameterized and made more specific by specifying a contained +type. For example, instead of just an C<ArrayRef> of anything, you can +specify that is an C<ArrayRef[Int]>. + +A parameterizable constraint should not be used as an attribute type +constraint. Instead, when parameterized it creates a +L<Moose::Meta::TypeConstraint::Parameterized> which should be used. + +=head1 INHERITANCE + +C<Moose::Meta::TypeConstraint::Parameterizable> is a subclass of +L<Moose::Meta::TypeConstraint>. + +=head1 METHODS + +This class is intentionally not documented because the API is +confusing and needs some work. + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/TypeConstraint/Parameterized.pm b/lib/Moose/Meta/TypeConstraint/Parameterized.pm new file mode 100644 index 0000000..8db9c88 --- /dev/null +++ b/lib/Moose/Meta/TypeConstraint/Parameterized.pm @@ -0,0 +1,188 @@ +package Moose::Meta::TypeConstraint::Parameterized; +our $VERSION = '2.1405'; + +use strict; +use warnings; +use metaclass; + +use Scalar::Util 'blessed'; +use Moose::Util::TypeConstraints; +use Moose::Meta::TypeConstraint::Parameterizable; +use Moose::Util 'throw_exception'; + +use parent 'Moose::Meta::TypeConstraint'; + +__PACKAGE__->meta->add_attribute('type_parameter' => ( + accessor => 'type_parameter', + predicate => 'has_type_parameter', + Class::MOP::_definition_context(), +)); + +__PACKAGE__->meta->add_attribute('parameterized_from' => ( + accessor => 'parameterized_from', + predicate => 'has_parameterized_from', + Class::MOP::_definition_context(), +)); + +sub equals { + my ( $self, $type_or_name ) = @_; + + my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name); + + return unless $other->isa(__PACKAGE__); + + return ( + $self->type_parameter->equals( $other->type_parameter ) + and + $self->parent->equals( $other->parent ) + ); +} + +sub compile_type_constraint { + my $self = shift; + + unless ( $self->has_type_parameter ) { + throw_exception( CannotCreateHigherOrderTypeWithoutATypeParameter => type_name => $self->name ); + } + + my $type_parameter = $self->type_parameter; + + unless ( blessed $type_parameter && $type_parameter->isa('Moose::Meta::TypeConstraint') ) { + throw_exception( TypeParameterMustBeMooseMetaType => type_name => $self->name ); + } + + foreach my $type (Moose::Util::TypeConstraints::get_all_parameterizable_types()) { + if (my $constraint = $type->generate_constraint_for($self)) { + $self->_set_constraint($constraint); + return $self->SUPER::compile_type_constraint; + } + } + + # if we get here, then we couldn't + # find a way to parameterize this type + throw_exception( TypeConstraintCannotBeUsedForAParameterizableType => type_name => $self->name, + parent_type_name => $self->parent->name, + ); +} + +sub can_be_inlined { + my $self = shift; + + return + $self->has_parameterized_from + && $self->parameterized_from->has_inline_generator + && $self->type_parameter->can_be_inlined; +} + +sub inline_environment { + my $self = shift; + + return { + ($self->has_parameterized_from + ? (%{ $self->parameterized_from->inline_environment }) + : ()), + ($self->has_type_parameter + ? (%{ $self->type_parameter->inline_environment }) + : ()), + }; +} + +sub _inline_check { + my $self = shift; + + return unless $self->can_be_inlined; + + return $self->parameterized_from->generate_inline_for( $self->type_parameter, @_ ); +} + +sub create_child_type { + my ($self, %opts) = @_; + return Moose::Meta::TypeConstraint::Parameterizable->new(%opts, parent=>$self); +} + +1; + +# ABSTRACT: Type constraints with a bound parameter (ArrayRef[Int]) + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::TypeConstraint::Parameterized - Type constraints with a bound parameter (ArrayRef[Int]) + +=head1 VERSION + +version 2.1405 + +=head1 METHODS + +This class is intentionally not documented because the API is +confusing and needs some work. + +=head1 INHERITANCE + +C<Moose::Meta::TypeConstraint::Parameterized> is a subclass of +L<Moose::Meta::TypeConstraint>. + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/TypeConstraint/Registry.pm b/lib/Moose/Meta/TypeConstraint/Registry.pm new file mode 100644 index 0000000..7c534a7 --- /dev/null +++ b/lib/Moose/Meta/TypeConstraint/Registry.pm @@ -0,0 +1,210 @@ +package Moose::Meta::TypeConstraint::Registry; +our $VERSION = '2.1405'; + +use strict; +use warnings; +use metaclass; + +use Scalar::Util 'blessed'; + +use parent 'Class::MOP::Object'; + +use Moose::Util 'throw_exception'; + +__PACKAGE__->meta->add_attribute('parent_registry' => ( + reader => 'get_parent_registry', + writer => 'set_parent_registry', + predicate => 'has_parent_registry', + Class::MOP::_definition_context(), +)); + +__PACKAGE__->meta->add_attribute('type_constraints' => ( + reader => 'type_constraints', + default => sub { {} }, + Class::MOP::_definition_context(), +)); + +sub new { + my $class = shift; + my $self = $class->_new(@_); + return $self; +} + +sub has_type_constraint { + my ($self, $type_name) = @_; + ($type_name and exists $self->type_constraints->{$type_name}) ? 1 : 0 +} + +sub get_type_constraint { + my ($self, $type_name) = @_; + return unless defined $type_name; + $self->type_constraints->{$type_name} +} + +sub add_type_constraint { + my ($self, $type) = @_; + + unless ( $type && blessed $type && $type->isa('Moose::Meta::TypeConstraint') ) { + throw_exception( InvalidTypeConstraint => registry_object => $self, + type => $type + ); + } + + $self->type_constraints->{$type->name} = $type; +} + +sub find_type_constraint { + my ($self, $type_name) = @_; + return $self->get_type_constraint($type_name) + if $self->has_type_constraint($type_name); + return $self->get_parent_registry->find_type_constraint($type_name) + if $self->has_parent_registry; + return; +} + +1; + +# ABSTRACT: registry for type constraints + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::TypeConstraint::Registry - registry for type constraints + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class is a registry that maps type constraint names to +L<Moose::Meta::TypeConstraint> objects. + +Currently, it is only used internally by +L<Moose::Util::TypeConstraints>, which creates a single global +registry. + +=head1 INHERITANCE + +C<Moose::Meta::TypeConstraint::Registry> is a subclass of +L<Class::MOP::Object>. + +=head1 METHODS + +=over 4 + +=item B<< Moose::Meta::TypeConstraint::Registry->new(%options) >> + +This creates a new registry object based on the provided C<%options>: + +=over 8 + +=item * parent_registry + +This is an optional L<Moose::Meta::TypeConstraint::Registry> +object. + +=item * type_constraints + +This is hash reference of type names to type objects. This is +optional. Constraints can be added to the registry after it is +created. + +=back + +=item B<< $registry->get_parent_registry >> + +Returns the registry's parent registry, if it has one. + +=item B<< $registry->has_parent_registry >> + +Returns true if the registry has a parent. + +=item B<< $registry->set_parent_registry($registry) >> + +Sets the parent registry. + +=item B<< $registry->get_type_constraint($type_name) >> + +This returns the L<Moose::Meta::TypeConstraint> object from the +registry for the given name, if one exists. + +=item B<< $registry->has_type_constraint($type_name) >> + +Returns true if the registry has a type of the given name. + +=item B<< $registry->add_type_constraint($type) >> + +Adds a new L<Moose::Meta::TypeConstraint> object to the registry. + +=item B<< $registry->find_type_constraint($type_name) >> + +This method looks in the current registry for the named type. If the +type is not found, then this method will look in the registry's +parent, if it has one. + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/TypeConstraint/Role.pm b/lib/Moose/Meta/TypeConstraint/Role.pm new file mode 100644 index 0000000..db609d9 --- /dev/null +++ b/lib/Moose/Meta/TypeConstraint/Role.pm @@ -0,0 +1,239 @@ +package Moose::Meta::TypeConstraint::Role; +our $VERSION = '2.1405'; + +use strict; +use warnings; +use metaclass; + +use B; +use Moose::Util::TypeConstraints (); +use Moose::Util (); + +use parent 'Moose::Meta::TypeConstraint'; + +__PACKAGE__->meta->add_attribute('role' => ( + reader => 'role', + Class::MOP::_definition_context(), +)); + +my $inliner = sub { + my $self = shift; + my $val = shift; + + return 'Moose::Util::does_role(' + . $val . ', ' + . B::perlstring($self->role) + . ')'; +}; + +sub new { + my ( $class, %args ) = @_; + + $args{parent} = Moose::Util::TypeConstraints::find_type_constraint('Object'); + + my $role_name = $args{role}; + $args{constraint} = sub { Moose::Util::does_role( $_[0], $role_name ) }; + + $args{inlined} = $inliner; + + my $self = $class->SUPER::new( \%args ); + + $self->compile_type_constraint(); + + return $self; +} + +sub parents { + my $self = shift; + return ( + $self->parent, + map { + # FIXME find_type_constraint might find a TC named after the role but that isn't really it + # I did this anyway since it's a convention that preceded TypeConstraint::Role, and it should DWIM + # if anybody thinks this problematic please discuss on IRC. + # a possible fix is to add by attr indexing to the type registry to find types of a certain property + # regardless of their name + Moose::Util::TypeConstraints::find_type_constraint($_) + || + __PACKAGE__->new( role => $_, name => "__ANON__" ) + } @{ Class::MOP::class_of($self->role)->get_roles }, + ); +} + +sub equals { + my ( $self, $type_or_name ) = @_; + + my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name); + + return unless defined $other; + return unless $other->isa(__PACKAGE__); + + return $self->role eq $other->role; +} + +sub is_a_type_of { + my ($self, $type_or_name) = @_; + + my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name); + + ($self->equals($type) || $self->is_subtype_of($type_or_name)); +} + +sub is_subtype_of { + my ($self, $type_or_name_or_role ) = @_; + + if ( not ref $type_or_name_or_role ) { + # it might be a role + my $class = Class::MOP::class_of($self->role); + return 1 if defined($class) && $class->does_role( $type_or_name_or_role ); + } + + my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name_or_role); + + return unless defined $type; + + if ( $type->isa(__PACKAGE__) ) { + # if $type_or_name_or_role isn't a role, it might be the TC name of another ::Role type + # or it could also just be a type object in this branch + my $class = Class::MOP::class_of($self->role); + return defined($class) && $class->does_role( $type->role ); + } else { + # the only other thing we are a subtype of is Object + $self->SUPER::is_subtype_of($type); + } +} + +sub create_child_type { + my ($self, @args) = @_; + return Moose::Meta::TypeConstraint->new(@args, parent => $self); +} + +1; + +# ABSTRACT: Role/TypeConstraint parallel hierarchy + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::TypeConstraint::Role - Role/TypeConstraint parallel hierarchy + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class represents type constraints for a role. + +=head1 INHERITANCE + +C<Moose::Meta::TypeConstraint::Role> is a subclass of +L<Moose::Meta::TypeConstraint>. + +=head1 METHODS + +=over 4 + +=item B<< Moose::Meta::TypeConstraint::Role->new(%options) >> + +This creates a new role type constraint based on the given +C<%options>. + +It takes the same options as its parent, with two exceptions. First, +it requires an additional option, C<role>, which is name of the +constraint's role. Second, it automatically sets the parent to the +C<Object> type. + +The constructor also overrides the hand optimized type constraint with +one it creates internally. + +=item B<< $constraint->role >> + +Returns the role name associated with the constraint. + +=item B<< $constraint->parents >> + +Returns all the type's parent types, corresponding to the roles that +its role does. + +=item B<< $constraint->is_subtype_of($type_name_or_object) >> + +If the given type is also a role type, then this checks that the +type's role does the other type's role. + +Otherwise it falls back to the implementation in +L<Moose::Meta::TypeConstraint>. + +=item B<< $constraint->create_child_type(%options) >> + +This returns a new L<Moose::Meta::TypeConstraint> object with the type +as its parent. + +Note that it does I<not> return a C<Moose::Meta::TypeConstraint::Role> +object! + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Moose/Meta/TypeConstraint/Union.pm b/lib/Moose/Meta/TypeConstraint/Union.pm new file mode 100644 index 0000000..da85f86 --- /dev/null +++ b/lib/Moose/Meta/TypeConstraint/Union.pm @@ -0,0 +1,348 @@ +package Moose::Meta::TypeConstraint::Union; +our $VERSION = '2.1405'; + +use strict; +use warnings; +use metaclass; + +use Moose::Meta::TypeCoercion::Union; + +use List::Util 1.33 qw(first all); + +use parent 'Moose::Meta::TypeConstraint'; + +__PACKAGE__->meta->add_attribute('type_constraints' => ( + accessor => 'type_constraints', + default => sub { [] }, + Class::MOP::_definition_context(), +)); + +sub new { + my ($class, %options) = @_; + + my $name = join '|' => sort { $a cmp $b } + map { $_->name } @{ $options{type_constraints} }; + + my $self = $class->SUPER::new( + name => $name, + %options, + ); + + $self->_set_constraint( $self->_compiled_type_constraint ); + + return $self; +} + +# XXX - this is a rather gross implementation of laziness for the benefit of +# MX::Types. If we try to call ->has_coercion on the objects during object +# construction, this does not work when defining a recursive constraint with +# MX::Types. +sub coercion { + my $self = shift; + + return $self->{coercion} if exists $self->{coercion}; + + # Using any instead of grep here causes a weird error with some corner + # cases when MX::Types is in use. See RT #61001. + if ( grep { $_->has_coercion } @{ $self->type_constraints } ) { + return $self->{coercion} = Moose::Meta::TypeCoercion::Union->new( + type_constraint => $self ); + } + else { + return $self->{coercion} = undef; + } +} + +sub has_coercion { + return defined $_[0]->coercion; +} + +sub _actually_compile_type_constraint { + my $self = shift; + + my @constraints = @{ $self->type_constraints }; + + return sub { + my $value = shift; + foreach my $type (@constraints) { + return 1 if $type->check($value); + } + return undef; + }; +} + +sub can_be_inlined { + my $self = shift; + + # This was originally done with all() from List::MoreUtils, but that + # caused some sort of bizarro parsing failure under 5.10. + for my $tc ( @{ $self->type_constraints } ) { + return 0 unless $tc->can_be_inlined; + } + + return 1; +} + +sub _inline_check { + my $self = shift; + my $val = shift; + + return '(' + . ( + join ' || ', map { '(' . $_->_inline_check($val) . ')' } + @{ $self->type_constraints } + ) + . ')'; +} + +sub inline_environment { + my $self = shift; + + return { map { %{ $_->inline_environment } } + @{ $self->type_constraints } }; +} + +sub equals { + my ( $self, $type_or_name ) = @_; + + my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name); + + return unless $other->isa(__PACKAGE__); + + my @self_constraints = @{ $self->type_constraints }; + my @other_constraints = @{ $other->type_constraints }; + + return unless @self_constraints == @other_constraints; + + # FIXME presort type constraints for efficiency? + constraint: foreach my $constraint ( @self_constraints ) { + for ( my $i = 0; $i < @other_constraints; $i++ ) { + if ( $constraint->equals($other_constraints[$i]) ) { + splice @other_constraints, $i, 1; + next constraint; + } + } + } + + return @other_constraints == 0; +} + +sub parent { + my $self = shift; + + my ($first, @rest) = @{ $self->type_constraints }; + + for my $parent ( $first->_collect_all_parents ) { + return $parent if all { $_->is_a_type_of($parent) } @rest; + } + + return; +} + +sub validate { + my ($self, $value) = @_; + my $message; + foreach my $type (@{$self->type_constraints}) { + my $err = $type->validate($value); + return unless defined $err; + $message .= ($message ? ' and ' : '') . $err + if defined $err; + } + return ($message . ' in (' . $self->name . ')') ; +} + +sub find_type_for { + my ($self, $value) = @_; + + return first { $_->check($value) } @{ $self->type_constraints }; +} + +sub is_a_type_of { + my ($self, $type_name) = @_; + + return all { $_->is_a_type_of($type_name) } @{ $self->type_constraints }; +} + +sub is_subtype_of { + my ($self, $type_name) = @_; + + return all { $_->is_subtype_of($type_name) } @{ $self->type_constraints }; +} + +sub create_child_type { + my ( $self, %opts ) = @_; + + my $constraint + = Moose::Meta::TypeConstraint->new( %opts, parent => $self ); + + # if we have a type constraint union, and no + # type check, this means we are just aliasing + # the union constraint, which means we need to + # handle this differently. + # - SL + if ( not( defined $opts{constraint} ) + && $self->has_coercion ) { + $constraint->coercion( + Moose::Meta::TypeCoercion::Union->new( + type_constraint => $self, + ) + ); + } + + return $constraint; +} + +1; + +# ABSTRACT: A union of Moose type constraints + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Moose::Meta::TypeConstraint::Union - A union of Moose type constraints + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This metaclass represents a union of type constraints. A union takes +multiple type constraints, and is true if any one of its member +constraints is true. + +=head1 INHERITANCE + +C<Moose::Meta::TypeConstraint::Union> is a subclass of +L<Moose::Meta::TypeConstraint>. + +=over 4 + +=item B<< Moose::Meta::TypeConstraint::Union->new(%options) >> + +This creates a new class type constraint based on the given +C<%options>. + +It takes the same options as its parent. It also requires an +additional option, C<type_constraints>. This is an array reference +containing the L<Moose::Meta::TypeConstraint> objects that are the +members of the union type. The C<name> option defaults to the names +all of these member types sorted and then joined by a pipe (|). + +The constructor sets the implementation of the constraint so that is +simply calls C<check> on the newly created object. + +Finally, the constructor also makes sure that the object's C<coercion> +attribute is a L<Moose::Meta::TypeCoercion::Union> object. + +=item B<< $constraint->type_constraints >> + +This returns the array reference of C<type_constraints> provided to +the constructor. + +=item B<< $constraint->parent >> + +This returns the nearest common ancestor of all the components of the union. + +=item B<< $constraint->check($value) >> + +=item B<< $constraint->validate($value) >> + +These two methods simply call the relevant method on each of the +member type constraints in the union. If any type accepts the value, +the value is valid. + +With C<validate> the error message returned includes all of the error +messages returned by the member type constraints. + +=item B<< $constraint->equals($type_name_or_object) >> + +A type is considered equal if it is also a union type, and the two +unions have the same member types. + +=item B<< $constraint->find_type_for($value) >> + +This returns the first member type constraint for which C<check($value)> is +true, allowing you to determine which of the Union's member type constraints +a given value matches. + +=item B<< $constraint->is_a_type_of($type_name_or_object) >> + +This returns true if all of the member type constraints return true +for the C<is_a_type_of> method. + +=item B<< $constraint->is_subtype_of >> + +This returns true if all of the member type constraints return true +for the C<is_a_subtype_of> method. + +=item B<< $constraint->create_child_type(%options) >> + +This returns a new L<Moose::Meta::TypeConstraint> object with the type +as its parent. + +=back + +=head1 BUGS + +See L<Moose/BUGS> for details on reporting bugs. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut |