+++ /dev/null
-package Moose::Meta::Attribute::Native::MethodProvider::Hash;
-use Moose::Role;
-
-our $VERSION = '1.14';
-$VERSION = eval $VERSION;
-our $AUTHORITY = 'cpan:STEVAN';
-
-sub exists : method {
- my ( $attr, $reader, $writer ) = @_;
- return sub { CORE::exists $reader->( $_[0] )->{ $_[1] } ? 1 : 0 };
-}
-
-sub defined : method {
- my ( $attr, $reader, $writer ) = @_;
- return sub { CORE::defined $reader->( $_[0] )->{ $_[1] } ? 1 : 0 };
-}
-
-sub get : method {
- my ( $attr, $reader, $writer ) = @_;
- return sub {
- if ( @_ == 2 ) {
- $reader->( $_[0] )->{ $_[1] };
- }
- else {
- my ( $self, @keys ) = @_;
- @{ $reader->($self) }{@keys};
- }
- };
-}
-
-sub keys : method {
- my ( $attr, $reader, $writer ) = @_;
- return sub { CORE::keys %{ $reader->( $_[0] ) } };
-}
-
-sub values : method {
- my ( $attr, $reader, $writer ) = @_;
- return sub { CORE::values %{ $reader->( $_[0] ) } };
-}
-
-sub kv : method {
- my ( $attr, $reader, $writer ) = @_;
- return sub {
- my $h = $reader->( $_[0] );
- map { [ $_, $h->{$_} ] } CORE::keys %{$h};
- };
-}
-
-sub elements : method {
- my ( $attr, $reader, $writer ) = @_;
- return sub {
- my $h = $reader->( $_[0] );
- map { $_, $h->{$_} } CORE::keys %{$h};
- };
-}
-
-sub count : method {
- my ( $attr, $reader, $writer ) = @_;
- return sub { scalar CORE::keys %{ $reader->( $_[0] ) } };
-}
-
-sub is_empty : method {
- my ( $attr, $reader, $writer ) = @_;
- return sub { scalar CORE::keys %{ $reader->( $_[0] ) } ? 0 : 1 };
-}
-
-
-sub set : method {
- my ( $attr, $reader, $writer ) = @_;
- if (
- $attr->has_type_constraint
- && $attr->type_constraint->isa(
- 'Moose::Meta::TypeConstraint::Parameterized')
- ) {
- my $container_type_constraint
- = $attr->type_constraint->type_parameter;
- return sub {
- my ( $self, @kvp ) = @_;
-
- my ( @keys, @values );
-
- while (@kvp) {
- my ( $key, $value ) = ( shift(@kvp), shift(@kvp) );
- ( $container_type_constraint->check($value) )
- || confess "Value "
- . ( $value || 'undef' )
- . " did not pass container type constraint '$container_type_constraint'";
- push @keys, $key;
- push @values, $value;
- }
-
- if ( @values > 1 ) {
- @{ $reader->($self) }{@keys} = @values;
- }
- else {
- $reader->($self)->{ $keys[0] } = $values[0];
- }
- };
- }
- else {
- return sub {
- if ( @_ == 3 ) {
- $reader->( $_[0] )->{ $_[1] } = $_[2];
- }
- else {
- my ( $self, @kvp ) = @_;
- my ( @keys, @values );
-
- while (@kvp) {
- push @keys, shift @kvp;
- push @values, shift @kvp;
- }
-
- @{ $reader->( $_[0] ) }{@keys} = @values;
- }
- };
- }
-}
-
-sub accessor : method {
- my ( $attr, $reader, $writer ) = @_;
-
- if (
- $attr->has_type_constraint
- && $attr->type_constraint->isa(
- 'Moose::Meta::TypeConstraint::Parameterized')
- ) {
- my $container_type_constraint
- = $attr->type_constraint->type_parameter;
- return sub {
- my $self = shift;
-
- if ( @_ == 1 ) { # reader
- return $reader->($self)->{ $_[0] };
- }
- elsif ( @_ == 2 ) { # writer
- ( $container_type_constraint->check( $_[1] ) )
- || confess "Value "
- . ( $_[1] || 'undef' )
- . " did not pass container type constraint '$container_type_constraint'";
- $reader->($self)->{ $_[0] } = $_[1];
- }
- else {
- confess "One or two arguments expected, not " . @_;
- }
- };
- }
- else {
- return sub {
- my $self = shift;
-
- if ( @_ == 1 ) { # reader
- return $reader->($self)->{ $_[0] };
- }
- elsif ( @_ == 2 ) { # writer
- $reader->($self)->{ $_[0] } = $_[1];
- }
- else {
- confess "One or two arguments expected, not " . @_;
- }
- };
- }
-}
-
-sub clear : method {
- my ( $attr, $reader, $writer ) = @_;
- return sub { %{ $reader->( $_[0] ) } = () };
-}
-
-sub delete : method {
- my ( $attr, $reader, $writer ) = @_;
- return sub {
- my $hashref = $reader->(shift);
- CORE::delete @{$hashref}{@_};
- };
-}
-
-1;
-
-__END__
-
-=pod
-
-=head1 NAME
-
-Moose::Meta::Attribute::Native::MethodProvider::Hash - role providing method generators for Hash trait
-
-=head1 DESCRIPTION
-
-This is a role which provides the method generators for
-L<Moose::Meta::Attribute::Native::Trait::Hash>. Please check there for
-documentation on what methods are provided.
-
-=head1 METHODS
-
-=over 4
-
-=item B<meta>
-
-=back
-
-=head1 BUGS
-
-See L<Moose/BUGS> for details on reporting bugs.
-
-=head1 AUTHOR
-
-Stevan Little E<lt>stevan@iinteractive.comE<gt>
-
-=head1 COPYRIGHT AND LICENSE
-
-Copyright 2007-2009 by Infinity Interactive, Inc.
-
-L<http://www.iinteractive.com>
-
-This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=cut
-
use Moose::Meta::Attribute::Native::MethodProvider::Hash;
+use Moose::Meta::Method::Accessor::Native::Hash::clear;
+use Moose::Meta::Method::Accessor::Native::Hash::count;
+use Moose::Meta::Method::Accessor::Native::Hash::defined;
+use Moose::Meta::Method::Accessor::Native::Hash::delete;
+use Moose::Meta::Method::Accessor::Native::Hash::elements;
+use Moose::Meta::Method::Accessor::Native::Hash::exists;
+use Moose::Meta::Method::Accessor::Native::Hash::get;
+use Moose::Meta::Method::Accessor::Native::Hash::is_empty;
+use Moose::Meta::Method::Accessor::Native::Hash::keys;
+use Moose::Meta::Method::Accessor::Native::Hash::kv;
+use Moose::Meta::Method::Accessor::Native::Hash::set;
+use Moose::Meta::Method::Accessor::Native::Hash::values;
+
with 'Moose::Meta::Attribute::Native::Trait';
has 'method_provider' => (
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
-# This package is really more of a role, so it doesn't inherit from anything.
-
sub _inline_check_var_is_valid_index {
my ( $self, $var ) = @_;
use strict;
use warnings;
+use Class::MOP::MiniTrait;
+
our $VERSION = '1.13';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
-use base qw(
- Moose::Meta::Method::Accessor::Native::Array
- Moose::Meta::Method::Accessor::Native::Writer
-);
-
-sub _new_value {'@_'}
-
-sub _value_needs_copy {
- my $self = shift;
-
- return $self->_constraint_must_be_checked
- && !$self->_check_new_members_only;
-}
-
-sub _inline_tc_code {
- my ( $self, $new_value, $potential_value ) = @_;
-
- return q{} unless $self->_constraint_must_be_checked;
-
- if ( $self->_check_new_members_only ) {
- return q{} unless $self->_adds_members;
-
- return $self->_inline_check_member_constraint($new_value);
- }
- else {
- return $self->_inline_check_coercion($potential_value) . "\n"
- . $self->_inline_check_constraint($potential_value);
- }
-}
-
-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 ArrayRef, that means we can just check the new members
- # of the collection, because we know that we will always be generating an
- # ArrayRef. However, if this type has its own constraint, we don't know
- # what the constraint checks, so we need to check the whole value, not
- # just the members.
- return 1
- if $tc->parent->name eq 'ArrayRef'
- && $tc->isa('Moose::Meta::TypeConstraint::Parameterized');
-
- return 0;
-}
-
-sub _inline_check_member_constraint {
- my ( $self, $new_value ) = @_;
-
- my $attr_name = $self->associated_attribute->name;
-
- return '$member_tc->($_) || '
- . $self->_inline_throw_error(
- qq{"A new member value for '$attr_name' does not pass its type constraint because: "}
- . ' . $member_tc->get_message($_)',
- "data => \$_"
- ) . " for $new_value;";
-}
-
-sub _inline_check_constraint {
- my $self = shift;
-
- return q{} unless $self->_constraint_must_be_checked;
-
- return $self->SUPER::_inline_check_constraint( $_[0] );
-}
+use base 'Moose::Meta::Method::Accessor::Native::Writer';
-sub _inline_get_old_value_for_trigger {
- my ( $self, $instance ) = @_;
-
- my $attr = $self->associated_attribute;
- return '' unless $attr->has_trigger;
-
- my $mi = $attr->associated_class->get_meta_instance;
- my $pred = $mi->inline_is_slot_initialized( $instance, $attr->name );
-
- return
- 'my @old = '
- . $pred . q{ ? } . '[ @{'
- . $self->_inline_get($instance)
- . '} ] : ()' . ";\n";
-}
-
-sub _eval_environment {
- my $self = shift;
-
- my $env = $self->SUPER::_eval_environment;
+Class::MOP::MiniTrait::apply( __PACKAGE__,
+ 'Moose::Meta::Method::Accessor::Native::Array'
+);
+Class::MOP::MiniTrait::apply( __PACKAGE__,
+ 'Moose::Meta::Method::Accessor::Native::Collection'
+);
- return $env
- unless $self->_constraint_must_be_checked
- and $self->_check_new_members_only;
+sub _new_members {'@_'}
- $env->{'$member_tc'}
- = \( $self->associated_attribute->type_constraint->type_parameter
- ->_compiled_type_constraint );
+sub _inline_copy_old_value {
+ my ( $self, $slot_access ) = @_;
- return $env;
+ return '[ @{' . $slot_access . '} ]';
}
1;
our $AUTHORITY = 'cpan:STEVAN';
use base qw(
- Moose::Meta::Method::Accessor::Native::Array::get
Moose::Meta::Method::Accessor::Native::Array::set
+ Moose::Meta::Method::Accessor::Native::Array::get
);
sub _generate_method {
$code .= "\n" . $self->_inline_check_var_is_valid_index('$_[0]');
- $code .= "\n" . 'return ' . $self->_return_value($slot_access) . ';';
+ $code
+ .= "\n"
+ . 'return '
+ . $self
+ ->Moose::Meta::Method::Accessor::Native::Array::get::_return_value(
+ $slot_access)
+ . ';';
# set
$code .= "\n" . '} else {';
. $self
->Moose::Meta::Method::Accessor::Native::Array::set::_inline_check_arguments;
- my $new_values = $self->_new_values($slot_access);
my $potential_value = $self->_potential_value($slot_access);
$code .= "\n"
. $self->_inline_tc_code(
- $new_values,
$potential_value,
$slot_access,
);
"( do { my \@potential = \@{ $slot_access }; \$potential[ \$_[0] ] = \$_[1]; \@potential } )";
}
-sub _new_values {'$_[1]'}
-
-sub _eval_environment {
- my $self = shift;
-
- my $env = $self->SUPER::_eval_environment;
-
- return $env
- unless $self->_constraint_must_be_checked
- and $self->_check_new_members_only;
-
- $env->{'$member_tc'}
- = \( $self->associated_attribute->type_constraint->type_parameter
- ->_compiled_type_constraint );
-
- return $env;
-}
+sub _new_members {'$_[1]'}
1;
use strict;
use warnings;
+use Class::MOP::MiniTrait;
+
our $VERSION = '1.13';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
-use base qw(
- Moose::Meta::Method::Accessor::Native::Array
- Moose::Meta::Method::Accessor::Native::Reader
+use base 'Moose::Meta::Method::Accessor::Native::Reader';
+
+Class::MOP::MiniTrait::apply( __PACKAGE__,
+ 'Moose::Meta::Method::Accessor::Native::Array'
);
sub _minimum_arguments { 1 }
"( do { my \@potential = \@{ $slot_access }; splice \@potential, \$_[0], 0, \$_[1]; \\\@potential } )";
}
-sub _new_values { '$_[1]' }
+sub _new_members { '$_[1]' }
sub _inline_optimized_set_new_value {
my ( $self, $inv, $new, $slot_access ) = @_;
"( do { my \@potential = \@{ $slot_access }; \$potential[ \$_[0] ] = \$_[1]; \\\@potential } )";
}
-sub _new_values { '$_[1]' }
+sub _new_members { '$_[1]' }
sub _inline_optimized_set_new_value {
my ( $self, $inv, $new, $slot_access ) = @_;
--- /dev/null
+package Moose::Meta::Method::Accessor::Native::Collection;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.13';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+sub _value_needs_copy {
+ shift;
+ my $self = shift;
+
+ return $self->_constraint_must_be_checked
+ && !$self->_check_new_members_only;
+}
+
+sub _inline_tc_code {
+ shift;
+ my ( $self, $potential_value ) = @_;
+
+ return q{} unless $self->_constraint_must_be_checked;
+
+ if ( $self->_check_new_members_only ) {
+ return q{} unless $self->_adds_members;
+
+ return $self->_inline_check_member_constraint( $self->_new_members );
+ }
+ else {
+ return $self->_inline_check_coercion($potential_value) . "\n"
+ . $self->_inline_check_constraint($potential_value);
+ }
+}
+
+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');
+
+ return 0;
+}
+
+sub _inline_check_member_constraint {
+ my ( $self, $new_value ) = @_;
+
+ my $attr_name = $self->associated_attribute->name;
+
+ return '$member_tc->($_) || '
+ . $self->_inline_throw_error(
+ qq{"A new member value for '$attr_name' does not pass its type constraint because: "}
+ . ' . $member_tc->get_message($_)',
+ "data => \$_"
+ ) . " for $new_value;";
+}
+
+sub _inline_check_constraint {
+ my $orig = shift;
+ my $self = shift;
+
+ return q{} unless $self->_constraint_must_be_checked;
+
+ return $self->$orig( $_[0] );
+}
+
+sub _inline_get_old_value_for_trigger {
+ shift;
+ my ( $self, $instance ) = @_;
+
+ my $attr = $self->associated_attribute;
+ return '' unless $attr->has_trigger;
+
+ my $mi = $attr->associated_class->get_meta_instance;
+ my $pred = $mi->inline_is_slot_initialized( $instance, $attr->name );
+
+ return
+ 'my @old = '
+ . $pred . q{ ? }
+ . $self->_inline_copy_old_value( $self->_inline_get($instance) )
+ . " : ();\n";
+}
+
+sub _eval_environment {
+ my $orig = shift;
+ my $self = shift;
+
+ my $env = $self->$orig(@_);
+
+ return $env
+ unless $self->_constraint_must_be_checked
+ && $self->_check_new_members_only;
+
+ $env->{'$member_tc'}
+ = \( $self->associated_attribute->type_constraint->type_parameter
+ ->_compiled_type_constraint );
+
+ return $env;
+}
+
+no Moose::Role;
+
+1;
use base 'Moose::Meta::Method::Accessor::Native::Writer';
-sub _new_value {'$_[0]'}
-
sub _constraint_must_be_checked {
my $self = shift;
--- /dev/null
+package Moose::Meta::Method::Accessor::Native::Hash;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.13';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+# This package is really more of a role, so it doesn't inherit from anything.
+
+sub _inline_check_var_is_valid_key {
+ my ( $self, $var ) = @_;
+
+ return $self->_inline_throw_error( q{'The key passed to }
+ . $self->delegate_to_method
+ . q{ must be a defined value'} )
+ . qq{ unless defined $var;};
+}
+
+1;
--- /dev/null
+package Moose::Meta::Method::Accessor::Native::Hash::Writer;
+
+use strict;
+use warnings;
+
+use Class::MOP::MiniTrait;
+
+our $VERSION = '1.13';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Moose::Meta::Method::Accessor::Native::Writer';
+
+Class::MOP::MiniTrait::apply( __PACKAGE__,
+ 'Moose::Meta::Method::Accessor::Native::Hash'
+);
+Class::MOP::MiniTrait::apply( __PACKAGE__,
+ 'Moose::Meta::Method::Accessor::Native::Collection'
+);
+
+sub _new_values {'@values'}
+
+sub _inline_copy_old_value {
+ my ( $self, $slot_access ) = @_;
+
+ return '{ @{' . $slot_access . '} }';
+}
+
+1;
--- /dev/null
+package Moose::Meta::Method::Accessor::Native::Hash::accessor;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.13';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base qw(
+ Moose::Meta::Method::Accessor::Native::Hash::set
+ Moose::Meta::Method::Accessor::Native::Hash::get
+);
+
+sub _generate_method {
+ my $self = shift;
+
+ my $inv = '$self';
+
+ my $code = 'sub {';
+ $code .= "\n" . $self->_inline_pre_body(@_);
+
+ $code .= "\n" . 'my $self = shift;';
+
+ $code .= "\n" . $self->_inline_curried_arguments;
+
+ $code .= "\n" . $self->_inline_check_lazy($inv);
+
+ my $slot_access = $self->_inline_get($inv);
+
+ # get
+ $code .= "\n" . 'if ( @_ == 1 ) {';
+
+ $code .= "\n" . $self->_inline_check_var_is_valid_index('$_[0]');
+
+ $code
+ .= "\n"
+ . 'return '
+ . $self
+ ->Moose::Meta::Method::Accessor::Native::Hash::get::_return_value(
+ $slot_access)
+ . ';';
+
+ # set
+ $code .= "\n" . '} else {';
+
+ $code .= "\n" . $self->_inline_check_argument_count;
+
+ $code
+ .= "\n"
+ . $self
+ ->Moose::Meta::Method::Accessor::Native::Hash::set::_inline_check_arguments;
+
+ my $potential_value = $self->_potential_value($slot_access);
+
+ $code .= "\n"
+ . $self->_inline_tc_code(
+ $potential_value,
+ $slot_access,
+ );
+
+ $code .= "\n" . $self->_inline_get_old_value_for_trigger($inv);
+ $code .= "\n" . $self->_inline_capture_return_value($slot_access);
+
+ $code
+ .= "\n" . $self->_inline_store( $inv, '[' . $potential_value . ']' );
+
+ $code .= "\n" . $self->_inline_post_body(@_);
+ $code .= "\n" . $self->_inline_trigger( $inv, $slot_access, '@old' );
+
+ $code .= "\n}";
+ $code .= "\n}";
+
+ return $code;
+}
+
+# If we get one argument we won't check the argument count
+sub _minimum_arguments {2}
+sub _maximum_arguments {2}
+
+sub _adds_members {1}
+
+sub _potential_value {
+ my ( $self, $slot_access ) = @_;
+
+ return "%{ $slot_access, @_ }";
+}
+
+sub _new_members {'$_[1]'}
+
+1;
--- /dev/null
+package Moose::Meta::Method::Accessor::Native::Hash::clear;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.13';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Moose::Meta::Method::Accessor::Native::Hash::Writer';
+
+sub _maximum_arguments { 0 }
+
+sub _adds_members { 0 }
+
+sub _potential_value { return '{}' }
+
+sub _inline_optimized_set_new_value {
+ my ( $self, $inv, $new, $slot_access ) = @_;
+
+ return "$slot_access = {};";
+}
+
+1;
--- /dev/null
+package Moose::Meta::Method::Accessor::Native::Hash::count;
+
+use strict;
+use warnings;
+
+use Scalar::Util qw( looks_like_number );
+
+our $VERSION = '1.13';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Moose::Meta::Method::Accessor::Native::Reader';
+
+sub _minimum_arguments { 0 }
+
+sub _maximum_arguments { 0 }
+
+sub _return_value {
+ my $self = shift;
+ my $slot_access = shift;
+
+ return "scalar keys \%{ $slot_access }";
+}
+
+
+1;
--- /dev/null
+package Moose::Meta::Method::Accessor::Native::Hash::defined;
+
+use strict;
+use warnings;
+
+use Scalar::Util qw( looks_like_number );
+
+our $VERSION = '1.13';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base qw(
+ Moose::Meta::Method::Accessor::Native::Hash
+ Moose::Meta::Method::Accessor::Native::Reader
+);
+
+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 "defined ${slot_access}->{ \$_[0] }";
+}
+
+
+1;
--- /dev/null
+package Moose::Meta::Method::Accessor::Native::Hash::delete;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.13';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Moose::Meta::Method::Accessor::Native::Hash::Writer';
+
+sub _adds_members { 0 }
+
+sub _potential_value {
+ my ( $self, $slot_access ) = @_;
+
+ return "( do { my \%potential = %{ $slot_access }; delete \@potential{\@_}; \\\%potential; } )";
+}
+
+sub _inline_optimized_set_new_value {
+ my ( $self, $inv, $new, $slot_access ) = @_;
+
+ return "delete \@{ $slot_access }{\@_};";
+}
+
+1;
--- /dev/null
+package Moose::Meta::Method::Accessor::Native::Hash::elements;
+
+use strict;
+use warnings;
+
+use Scalar::Util qw( looks_like_number );
+
+our $VERSION = '1.13';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Moose::Meta::Method::Accessor::Native::Reader';
+
+sub _minimum_arguments { 0 }
+
+sub _maximum_arguments { 0 }
+
+sub _return_value {
+ my $self = shift;
+ my $slot_access = shift;
+
+ return "map { \$_, ${slot_access}->{\$_} } keys \%{ $slot_access }";
+}
+
+
+1;
--- /dev/null
+package Moose::Meta::Method::Accessor::Native::Hash::exists;
+
+use strict;
+use warnings;
+
+use Scalar::Util qw( looks_like_number );
+
+our $VERSION = '1.13';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base qw(
+ Moose::Meta::Method::Accessor::Native::Hash
+ Moose::Meta::Method::Accessor::Native::Reader
+);
+
+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] }";
+}
+
+
+1;
--- /dev/null
+package Moose::Meta::Method::Accessor::Native::Hash::get;
+
+use strict;
+use warnings;
+
+use Scalar::Util qw( looks_like_number );
+
+our $VERSION = '1.13';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Moose::Meta::Method::Accessor::Native::Reader';
+
+Class::MOP::MiniTrait::apply( __PACKAGE__,
+ 'Moose::Meta::Method::Accessor::Native::Hash'
+);
+
+sub _minimum_arguments { 1 }
+
+sub _maximum_arguments { undef }
+
+sub _inline_check_arguments {
+ my $self = shift;
+
+ return
+ 'for (@_) {' . "\n"
+ . $self->_inline_check_var_is_valid_key('$_') . "\n" . '}';
+}
+
+sub _return_value {
+ my $self = shift;
+ my $slot_access = shift;
+
+ return "\@_ > 1 ? \@{ $slot_access }{\@_} : ${slot_access}->{ \$_[0] }";
+}
+
+
+1;
--- /dev/null
+package Moose::Meta::Method::Accessor::Native::Hash::is_empty;
+
+use strict;
+use warnings;
+
+use Scalar::Util qw( looks_like_number );
+
+our $VERSION = '1.13';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Moose::Meta::Method::Accessor::Native::Reader';
+
+sub _minimum_arguments { 0 }
+
+sub _maximum_arguments { 0 }
+
+sub _return_value {
+ my $self = shift;
+ my $slot_access = shift;
+
+ return "scalar keys \%{ $slot_access } ? 0 : 1";
+}
+
+
+1;
--- /dev/null
+package Moose::Meta::Method::Accessor::Native::Hash::keys;
+
+use strict;
+use warnings;
+
+use Scalar::Util qw( looks_like_number );
+
+our $VERSION = '1.13';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Moose::Meta::Method::Accessor::Native::Reader';
+
+sub _minimum_arguments { 0 }
+
+sub _maximum_arguments { 0 }
+
+sub _return_value {
+ my $self = shift;
+ my $slot_access = shift;
+
+ return "keys \%{ $slot_access }";
+}
+
+
+1;
--- /dev/null
+package Moose::Meta::Method::Accessor::Native::Hash::kv;
+
+use strict;
+use warnings;
+
+use Scalar::Util qw( looks_like_number );
+
+our $VERSION = '1.13';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Moose::Meta::Method::Accessor::Native::Reader';
+
+sub _minimum_arguments { 0 }
+
+sub _maximum_arguments { 0 }
+
+sub _return_value {
+ my $self = shift;
+ my $slot_access = shift;
+
+ return "map { [ \$_, ${slot_access}->{\$_} ] } keys \%{ $slot_access }";
+}
+
+
+1;
--- /dev/null
+package Moose::Meta::Method::Accessor::Native::Hash::set;
+
+use strict;
+use warnings;
+
+use Scalar::Util qw( looks_like_number );
+
+our $VERSION = '1.13';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Moose::Meta::Method::Accessor::Native::Hash::Writer';
+
+sub _minimum_arguments { 2 }
+
+sub _maximum_arguments { undef }
+
+sub _inline_check_argument_count {
+ my $self = shift;
+
+ return
+ $self->SUPER::_inline_check_argument_count(@_) . "\n"
+ . $self->_inline_throw_error(
+ q{'You must pass an even number of arguments to set'})
+ . ' if @_ % 2;';
+}
+
+sub _inline_process_arguments {
+ my $self = shift;
+
+ return 'my @keys_idx = grep { ! ($_ % 2) } 0..$#_;' . "\n"
+ . 'my @values_idx = grep { $_ % 2 } 0..$#_;';
+}
+
+sub _inline_check_arguments {
+ my $self = shift;
+
+ return
+ 'for (@keys_idx) {' . "\n"
+ . $self->_inline_throw_error(
+ q{'Hash keys passed to set must be defined'})
+ . ' unless defined $_[$_];' . "\n" . '}';
+}
+
+sub _adds_members { 1 }
+
+sub _potential_value {
+ my ( $self, $slot_access ) = @_;
+
+ return "%{ $slot_access, @_ }";
+}
+
+sub _new_members { '@_[ @values_idx ]' }
+
+sub _inline_optimized_set_new_value {
+ my ( $self, $inv, $new, $slot_access ) = @_;
+
+ return "\@{ $slot_access }{ \@_[ \@keys_idx] } = \@_[ \@values_idx ];";
+}
+
+1;
--- /dev/null
+package Moose::Meta::Method::Accessor::Native::Hash::values;
+
+use strict;
+use warnings;
+
+use Scalar::Util qw( looks_like_number );
+
+our $VERSION = '1.13';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Moose::Meta::Method::Accessor::Native::Reader';
+
+sub _minimum_arguments { 0 }
+
+sub _maximum_arguments { 0 }
+
+sub _return_value {
+ my $self = shift;
+ my $slot_access = shift;
+
+ return "values \%{ $slot_access }";
+}
+
+
+1;
$code .= "\n" . $self->_inline_check_lazy($inv);
- my $new_value = $self->_new_value($slot_access);
my $potential_value = $self->_potential_value($slot_access);
$code .= "\n" . $self->_inline_copy_value( \$potential_value );
$code .= "\n"
. $self->_inline_tc_code(
- $new_value,
$potential_value
);
sub _inline_check_arguments {q{}}
-sub _new_value {'$_[0]'}
-
sub _value_needs_copy {
my $self = shift;
}
sub _inline_tc_code {
- my ( $self, $new_value, $potential_value ) = @_;
+ my ( $self, $potential_value ) = @_;
return q{} unless $self->_constraint_must_be_checked;
is_deeply( $stuff->options, {}, '... no options yet' );
ok( !$stuff->has_option('foo'), '... we have no foo option' );
-my $set_result;
lives_ok {
- $set_result = $stuff->set_option( foo => 'bar' );
+ $stuff->set_option( foo => 'bar' );
}
'... set the option okay';
-is($set_result, 'bar', '... returns value set');
ok( $stuff->is_defined('foo'), '... foo is defined' );
is_deeply( $stuff->options, { foo => 'bar' }, '... got options now' );
lives_ok {
- $set_result = $stuff->set_option( bar => 'baz' );
+ $stuff->set_option( bar => 'baz' );
}
'... set the option okay';
-is($set_result, 'baz', '... returns value set');
is( $stuff->num_options, 2, '... we have 2 option(s)' );
is_deeply( $stuff->options, { foo => 'bar', bar => 'baz' },
is( scalar($stuff->get_option(qw( foo bar) )), "baz",
'... got last option in scalar context');
-my @set_return;
lives_ok {
- @set_return = $stuff->set_option( oink => "blah", xxy => "flop" );
+ $stuff->set_option( oink => "blah", xxy => "flop" );
}
'... set the option okay';
-is_deeply(\@set_return, [ qw(blah flop) ], '... and returns values set');
is( $stuff->num_options, 4, "4 options" );
is_deeply( [ $stuff->get_option(qw(foo bar oink xxy)) ],
projects / gitmo/Moose.git / commitdiff