diff options
Diffstat (limited to 'lib/Moose/Meta/Method')
83 files changed, 4479 insertions, 0 deletions
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 |