Lots of refactoring to existing native trait inlining code to share more between different types.
+++ /dev/null
-package Moose::Meta::Attribute::Native::MethodProvider::String;
-use Moose::Role;
-
-our $VERSION = '1.14';
-$VERSION = eval $VERSION;
-our $AUTHORITY = 'cpan:STEVAN';
-
-sub append : method {
- my ( $attr, $reader, $writer ) = @_;
-
- return sub { $writer->( $_[0], $reader->( $_[0] ) . $_[1] ) };
-}
-
-sub prepend : method {
- my ( $attr, $reader, $writer ) = @_;
-
- return sub { $writer->( $_[0], $_[1] . $reader->( $_[0] ) ) };
-}
-
-sub replace : method {
- my ( $attr, $reader, $writer ) = @_;
-
- return sub {
- my ( $self, $regex, $replacement ) = @_;
- my $v = $reader->( $_[0] );
-
- if ( ( ref($replacement) || '' ) eq 'CODE' ) {
- $v =~ s/$regex/$replacement->()/e;
- }
- else {
- $v =~ s/$regex/$replacement/;
- }
-
- $writer->( $_[0], $v );
- };
-}
-
-sub match : method {
- my ( $attr, $reader, $writer ) = @_;
- return sub { $reader->( $_[0] ) =~ $_[1] };
-}
-
-sub chop : method {
- my ( $attr, $reader, $writer ) = @_;
- return sub {
- my $v = $reader->( $_[0] );
- CORE::chop($v);
- $writer->( $_[0], $v );
- };
-}
-
-sub chomp : method {
- my ( $attr, $reader, $writer ) = @_;
- return sub {
- my $v = $reader->( $_[0] );
- chomp($v);
- $writer->( $_[0], $v );
- };
-}
-
-sub inc : method {
- my ( $attr, $reader, $writer ) = @_;
- return sub {
- my $v = $reader->( $_[0] );
- $v++;
- $writer->( $_[0], $v );
- };
-}
-
-sub clear : method {
- my ( $attr, $reader, $writer ) = @_;
- return sub { $writer->( $_[0], '' ) }
-}
-
-sub length : method {
- my ($attr, $reader, $writer) = @_;
- return sub {
- my $v = $reader->($_[0]);
- return CORE::length($v);
- };
-}
-
-sub substr : method {
- my ( $attr, $reader, $writer ) = @_;
- return sub {
- my $self = shift;
- my $v = $reader->($self);
-
- my $offset = defined $_[0] ? shift : 0;
- my $length = defined $_[0] ? shift : CORE::length($v);
- my $replacement = defined $_[0] ? shift : undef;
-
- my $ret;
- if ( defined $replacement ) {
- $ret = CORE::substr( $v, $offset, $length, $replacement );
- $writer->( $self, $v );
- }
- else {
- $ret = CORE::substr( $v, $offset, $length );
- }
-
- return $ret;
- };
-}
-
-1;
-
-__END__
-
-=pod
-
-=head1 NAME
-
-Moose::Meta::Attribute::Native::MethodProvider::String - role providing method generators for String trait
-
-=head1 DESCRIPTION
-
-This is a role which provides the method generators for
-L<Moose::Meta::Attribute::Native::Trait::String>. 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
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
-use Moose::Meta::Attribute::Native::MethodProvider::String;
+use Moose::Meta::Method::Accessor::Native::String::append;
+use Moose::Meta::Method::Accessor::Native::String::chomp;
+use Moose::Meta::Method::Accessor::Native::String::chop;
+use Moose::Meta::Method::Accessor::Native::String::clear;
+use Moose::Meta::Method::Accessor::Native::String::inc;
+use Moose::Meta::Method::Accessor::Native::String::length;
+use Moose::Meta::Method::Accessor::Native::String::match;
+use Moose::Meta::Method::Accessor::Native::String::prepend;
+use Moose::Meta::Method::Accessor::Native::String::replace;
+use Moose::Meta::Method::Accessor::Native::String::substr;
with 'Moose::Meta::Attribute::Native::Trait';
-has 'method_provider' => (
- is => 'ro',
- isa => 'ClassName',
- predicate => 'has_method_provider',
- default => 'Moose::Meta::Attribute::Native::MethodProvider::String',
-);
-
sub _default_default { q{} }
sub _default_is { 'rw' }
sub _helper_type { 'Str' }
+sub _native_type { 'String' }
+
no Moose::Role;
1;
sub _maximum_arguments { 0 }
sub _return_value {
- my $self = shift;
- my $slot_access = shift;
+ my ( $self, $slot_access ) = @_;
return "scalar \@{ $slot_access }";
}
$code .= "\n" . $self->_inline_pre_body(@_);
$code .= "\n" . 'my $self = shift;';
+
$code .= "\n" . $self->_inline_curried_arguments;
+
+ my $slot_access = $self->_inline_get($inv);
+
+ $code .= "\n" . $self->_reader_core( $inv, $slot_access, @_ );
+
+ $code .= "\n}";
+
+ return $code;
+}
+
+sub _reader_core {
+ my ( $self, $inv, $slot_access, @extra ) = @_;
+
+ my $code = q{};
+
$code .= "\n" . $self->_inline_check_argument_count;
+ $code .= "\n" . $self->_inline_process_arguments( $inv, $slot_access );
$code .= "\n" . $self->_inline_check_arguments;
$code .= "\n" . $self->_inline_check_lazy($inv);
- $code .= "\n" . $self->_inline_post_body(@_);
-
- my $slot_access = $self->_inline_get($inv);
-
+ $code .= "\n" . $self->_inline_post_body(@extra);
$code .= "\n" . $self->_inline_return_value($slot_access);
- $code .= "\n}";
return $code;
}
+sub _inline_process_arguments {q{}}
+
sub _inline_return_value {
my ( $self, $slot_access ) = @_;
--- /dev/null
+package Moose::Meta::Method::Accessor::Native::String;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.13';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+1;
--- /dev/null
+package Moose::Meta::Method::Accessor::Native::String::Reader;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.13';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base qw(
+ Moose::Meta::Method::Accessor::Native::String
+ Moose::Meta::Method::Accessor::Native::Reader
+);
+
+1;
--- /dev/null
+package Moose::Meta::Method::Accessor::Native::String::Writer;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.13';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base qw(
+ Moose::Meta::Method::Accessor::Native::String
+ Moose::Meta::Method::Accessor::Native::Writer
+);
+
+sub _new_value {'$_[0]'}
+
+sub _inline_copy_value {
+ my ( $self, $potential_ref ) = @_;
+
+ return q{} unless $self->_value_needs_copy;
+
+ my $code = "my \$potential = ${$potential_ref};";
+
+ ${$potential_ref} = '$potential';
+
+ return $code;
+}
+
+sub _value_needs_copy {
+ my $self = shift;
+
+ return $self->_constraint_must_be_checked;
+}
+
+sub _inline_tc_code {
+ my ( $self, $new_value, $potential_value ) = @_;
+
+ return q{} unless $self->_constraint_must_be_checked;
+
+ return $self->_inline_check_coercion($potential_value) . "\n"
+ . $self->_inline_check_constraint($potential_value);
+}
+
+sub _constraint_must_be_checked {
+ my $self = shift;
+
+ my $attr = $self->associated_attribute;
+
+ return $attr->has_type_constraint
+ && ( $attr->type_constraint->name ne 'Str'
+ || ( $attr->should_coerce && $attr->type_constraint->has_coercion ) );
+}
+
+sub _inline_check_coercion {
+ my ( $self, $value ) = @_;
+
+ my $attr = $self->associated_attribute;
+
+ return ''
+ unless $attr->should_coerce && $attr->type_constraint->has_coercion;
+
+ # We want to break the aliasing in @_ in case the coercion tries to make a
+ # destructive change to an array member.
+ return '@_ = @{ $attr->type_constraint->coerce($value) };';
+}
+
+1;
--- /dev/null
+package Moose::Meta::Method::Accessor::Native::String::append;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.13';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Moose::Meta::Method::Accessor::Native::String::Writer';
+
+sub _minimum_arguments { 1 }
+sub _maximum_arguments { 1 }
+
+sub _potential_value {
+ my ( $self, $slot_access ) = @_;
+
+ return "( $slot_access . \$_[0] )";
+}
+
+1;
--- /dev/null
+package Moose::Meta::Method::Accessor::Native::String::chomp;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.13';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Moose::Meta::Method::Accessor::Native::String::Writer';
+
+sub _minimum_arguments { 0 }
+sub _maximum_arguments { 0 }
+
+sub _potential_value {
+ my ( $self, $slot_access ) = @_;
+
+ return "( do { my \$val = $slot_access; chomp \$val; \$val } )";
+}
+
+sub _inline_set_new_value {
+ my ( $self, $inv, $new ) = @_;
+
+ return $self->SUPER::_inline_set_new_value(@_)
+ if $self->_value_needs_copy;
+
+ my $slot_access = $self->_inline_get($inv);
+
+ return "chomp ${slot_access}";
+}
+
+1;
--- /dev/null
+package Moose::Meta::Method::Accessor::Native::String::chop;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.13';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Moose::Meta::Method::Accessor::Native::String::Writer';
+
+sub _minimum_arguments { 0 }
+sub _maximum_arguments { 0 }
+
+sub _potential_value {
+ my ( $self, $slot_access ) = @_;
+
+ return "( do { my \$val = $slot_access; chop \$val; \$val } )";
+}
+
+sub _inline_set_new_value {
+ my ( $self, $inv, $new ) = @_;
+
+ return $self->SUPER::_inline_set_new_value(@_)
+ if $self->_value_needs_copy;
+
+ my $slot_access = $self->_inline_get($inv);
+
+ return "chop ${slot_access}";
+}
+
+1;
--- /dev/null
+package Moose::Meta::Method::Accessor::Native::String::clear;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.13';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Moose::Meta::Method::Accessor::Native::String::Writer';
+
+sub _minimum_arguments { 0 }
+sub _maximum_arguments { 0 }
+
+sub _potential_value {
+ my ( $self, $slot_access ) = @_;
+
+ return "q{}";
+}
+
+sub _inline_set_new_value {
+ my ( $self, $inv, $new ) = @_;
+
+ return $self->SUPER::_inline_set_new_value(@_)
+ if $self->_value_needs_copy;
+
+ my $slot_access = $self->_inline_get($inv);
+
+ return "${slot_access} = q{}";
+}
+
+1;
--- /dev/null
+package Moose::Meta::Method::Accessor::Native::String::inc;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.13';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Moose::Meta::Method::Accessor::Native::String::Writer';
+
+sub _minimum_arguments { 0 }
+sub _maximum_arguments { 0 }
+
+sub _potential_value {
+ my ( $self, $slot_access ) = @_;
+
+ return "( do { my \$val = $slot_access; \$val++ } )";
+}
+
+sub _inline_set_new_value {
+ my ( $self, $inv, $new ) = @_;
+
+ return $self->SUPER::_inline_set_new_value(@_)
+ if $self->_value_needs_copy;
+
+ my $slot_access = $self->_inline_get($inv);
+
+ return "${slot_access}++";
+}
+
+1;
--- /dev/null
+package Moose::Meta::Method::Accessor::Native::String::length;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.13';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Moose::Meta::Method::Accessor::Native::String::Reader';
+
+sub _minimum_arguments { 0 }
+sub _maximum_arguments { 0 }
+
+sub _return_value {
+ my ( $self, $slot_access ) = @_;
+
+ return "length $slot_access";
+}
+
+1;
--- /dev/null
+package Moose::Meta::Method::Accessor::Native::String::match;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.13';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Moose::Meta::Method::Accessor::Native::String::Reader';
+
+sub _minimum_arguments { 1 }
+sub _maximum_arguments { 1 }
+
+sub _inline_check_arguments {
+ my $self = shift;
+
+ return $self->_inline_throw_error(
+ q{'The argument passed to match must be a string or regexp reference'}
+ ) . q{ unless ! ref $_[0] || ref $_[0] eq 'Regexp';};
+}
+
+sub _return_value {
+ my ( $self, $slot_access ) = @_;
+
+ return "$slot_access =~ \$_[0]";
+}
+
+1;
--- /dev/null
+package Moose::Meta::Method::Accessor::Native::String::prepend;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.13';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Moose::Meta::Method::Accessor::Native::String::Writer';
+
+sub _minimum_arguments { 1 }
+sub _maximum_arguments { 1 }
+
+sub _potential_value {
+ my ( $self, $slot_access ) = @_;
+
+ return "( \$_[0] . $slot_access )";
+}
+
+1;
--- /dev/null
+package Moose::Meta::Method::Accessor::Native::String::replace;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.13';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Moose::Meta::Method::Accessor::Native::String::Writer';
+
+sub _minimum_arguments { 1 }
+sub _maximum_arguments { 2 }
+
+sub _inline_check_arguments {
+ my $self = shift;
+
+ return $self->_inline_throw_error(
+ q{'The first argument passed to replace must be a string or regexp reference'}
+ )
+ . q{ unless ! ref $_[0] || ref $_[0] eq 'Regexp';} . "\n"
+ . $self->_inline_throw_error(
+ q{'The second argument passed to replace must be a string or code reference'}
+ ) . q{ unless ! ref $_[1] || ref $_[1] eq 'CODE';};
+}
+
+sub _potential_value {
+ my ( $self, $slot_access ) = @_;
+
+ return "( do { my \$val = $slot_access; ref \$_[1] ? \$val =~ s/\$_[0]/\$_[1]->()/e : \$val =~ s/\$_[0]/\$_[1]/; \$val } )";
+}
+
+sub _inline_set_new_value {
+ my ( $self, $inv, $new ) = @_;
+
+ return $self->SUPER::_inline_set_new_value(@_)
+ if $self->_value_needs_copy;
+
+ my $slot_access = $self->_inline_get($inv);
+
+ return "if ( ref \$_[1] ) { $slot_access =~ s/\$_[0]/\$_[1]->()/e; } else { $slot_access =~ s/\$_[0]/\$_[1]/; }";
+}
+
+1;
--- /dev/null
+package Moose::Meta::Method::Accessor::Native::String::substr;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.13';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base qw(
+ Moose::Meta::Method::Accessor::Native::String::Reader
+ Moose::Meta::Method::Accessor::Native::String::Writer
+);
+
+sub _generate_method {
+ my $self = shift;
+
+ my $inv = '$self';
+
+ my $slot_access = $self->_inline_get($inv);
+
+ my $code = 'sub {';
+
+ $code .= "\n" . $self->_inline_pre_body(@_);
+ $code .= "\n" . 'my $self = shift;';
+
+ $code .= "\n" . $self->_inline_curried_arguments;
+
+ $code .= "\n" . 'if ( @_ == 1 || @_ == 2 ) {';
+
+ $code .= $self->_reader_core( $inv, $slot_access, @_ );
+
+ $code .= "\n" . '} elsif ( @_ == 3 ) {';
+
+ $code .= $self->_writer_core( $inv, $slot_access, @_ );
+
+ $code .= "\n" . $self->_inline_post_body(@_);
+
+ $code .= "\n" . '} else {';
+
+ $code .= "\n" . $self->_inline_check_argument_count;
+
+ $code .= "\n" . '}';
+ $code .= "\n" . '}';
+
+ return $code;
+}
+
+sub _minimum_arguments {1}
+sub _maximum_arguments {3}
+
+sub _inline_process_arguments {
+ my ( $self, $inv, $slot_access ) = @_;
+
+ return
+ 'my $offset = shift;' . "\n"
+ . "my \$length = \@_ ? shift : length $slot_access;" . "\n"
+ . 'my $replacement = shift;';
+}
+
+sub _inline_check_arguments {
+ my ( $self, $for_writer ) = @_;
+
+ my $code
+ = $self->_inline_throw_error(
+ q{'The first argument passed to substr must be an integer'})
+ . q{ if ref $offset || $offset !~ /^-?\\d+$/;} . "\n"
+ . $self->_inline_throw_error(
+ q{'The second argument passed to substr must be a positive integer'})
+ . q{ if ref $length || $offset !~ /^-?\\d+$/;};
+
+ if ($for_writer) {
+ $code
+ .= "\n"
+ . $self->_inline_throw_error(
+ q{'The third argument passed to substr must be a string'})
+ . q{ unless defined $replacement && ! ref $replacement;};
+ }
+
+ return $code;
+}
+
+sub _potential_value {
+ my ( $self, $slot_access ) = @_;
+
+ return
+ "( do { my \$potential = $slot_access; substr \$potential, \$offset, \$length, \$replacement; \$potential; } )";
+}
+
+sub _inline_set_new_value {
+ my ( $self, $inv, $new ) = @_;
+
+ return $self->SUPER::_inline_set_new_value(@_)
+ if $self->_value_needs_copy;
+
+ my $slot_access = $self->_inline_get($inv);
+
+ return "substr $slot_access, \$offset, \$length, \$replacement;";
+}
+
+sub _return_value {
+ my ( $self, $slot_access, $for_writer ) = @_;
+
+ return q{} if $for_writer;
+
+ return "substr $slot_access, \$offset, \$length";
+}
+
+1;
my $slot_access = $self->_inline_get($inv);
my $code = 'sub {';
+
$code .= "\n" . $self->_inline_pre_body(@_);
$code .= "\n" . 'my $self = shift;';
- $code .= "\n" . $self->_inline_check_lazy($inv);
-
$code .= "\n" . $self->_inline_curried_arguments;
- $code .= "\n" . $self->_inline_check_argument_count;
+ $code .= $self->_writer_core( $inv, $slot_access );
- $code .= "\n" . $self->_inline_process_arguments;
+ $code .= "\n" . $self->_inline_post_body(@_);
+
+ $code .= "\n}";
- $code .= "\n" . $self->_inline_check_arguments;
+ return $code;
+}
+
+sub _writer_core {
+ my ( $self, $inv, $slot_access ) = @_;
+
+ my $code = q{};
+
+ $code .= "\n" . $self->_inline_check_argument_count;
+ $code .= "\n" . $self->_inline_process_arguments( $inv, $slot_access );
+ $code .= "\n" . $self->_inline_check_arguments('for writer');
+
+ $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,
$code .= "\n" . $self->_inline_get_old_value_for_trigger($inv);
$code .= "\n" . $self->_capture_old_value($slot_access);
-
$code .= "\n"
. $self->_inline_set_new_value(
$inv,
$potential_value
);
-
- $code .= "\n" . $self->_inline_post_body(@_);
$code .= "\n" . $self->_inline_trigger( $inv, $slot_access, '@old' );
-
- $code .= "\n" . $self->_return_value( $inv, '@old' );
-
- $code .= "\n}";
+ $code .= "\n" . $self->_return_value( $inv, '@old', 'for writer' );
return $code;
}
sub _value_needs_copy {0}
-sub _inline_tc_code {die}
+sub _inline_tc_code {
+ die '_inline_tc_code must be overridden by ' . ref $_[0];
+}
-sub _inline_check_coercion {die}
+sub _inline_check_coercion {
+ die '_inline_check_coercion must be overridden by ' . ref $_[0];
+}
sub _inline_check_constraint {
my $self = shift;
return $self->SUPER::_inline_check_constraint( $_[0] );
}
-sub _constraint_must_be_checked {die}
+sub _constraint_must_be_checked {
+ die '_constraint_must_be_checked must be overridden by ' . ref $_[0];
+}
sub _capture_old_value { return q{} }
return $self->SUPER::_inline_store(@_);
}
-sub _return_value { return q{} }
+sub _return_value { return q{} }
1;
use strict;
use warnings;
+use Moose ();
use Test::More;
-use Test::Moose 'does_ok';
+use Test::Exception;
+use Test::Moose;
-my $uc;
{
- package MyHomePage;
- use Moose;
-
- has 'string' => (
- traits => ['String'],
- is => 'rw',
- isa => 'Str',
- default => sub {''},
- handles => {
- inc_string => 'inc',
- append_string => 'append',
- prepend_string => 'prepend',
- match_string => 'match',
- replace_string => 'replace',
- chop_string => 'chop',
- chomp_string => 'chomp',
- clear_string => 'clear',
- length_string => 'length',
- exclaim => [ append => '!' ],
- capitalize_last => [ replace => qr/(.)$/, ($uc = sub { uc $1 }) ],
- invalid_number => [ match => qr/\D/ ],
- },
+ my %handles = (
+ inc => 'inc',
+ append => 'append',
+ append_curried => [ append => '!' ],
+ prepend => 'prepend',
+ prepend_curried => [ prepend => '-' ],
+ replace => 'replace',
+ replace_curried => [ replace => qr/(.)$/, sub { uc $1 } ],
+ chop => 'chop',
+ chomp => 'chomp',
+ clear => 'clear',
+ match => 'match',
+ match_curried => [ match => qr/\D/ ],
+ length => 'length',
+ substr => 'substr',
+ substr_curried_1 => [ substr => (1) ],
+ substr_curried_2 => [ substr => ( 1, 3 ) ],
+ substr_curried_3 => [ substr => ( 1, 3, 'ong' ) ],
);
+
+ my $name = 'Foo1';
+
+ sub build_class {
+ my %attr = @_;
+
+ my $class = Moose::Meta::Class->create(
+ $name++,
+ superclasses => ['Moose::Object'],
+ );
+
+ $class->add_attribute(
+ _string => (
+ traits => ['String'],
+ is => 'rw',
+ isa => 'Str',
+ default => q{},
+ handles => \%handles,
+ clearer => '_clear_string',
+ %attr,
+ ),
+ );
+
+ return ( $class->name, \%handles );
+ }
}
-my $page = MyHomePage->new();
-isa_ok( $page, 'MyHomePage' );
+{
+ run_tests(build_class);
+ run_tests( build_class( lazy => 1, default => q{} ) );
+}
+
+sub run_tests {
+ my ( $class, $handles ) = @_;
+
+ can_ok( $class, $_ ) for sort keys %{$handles};
+
+ with_immutable {
+ my $obj = $class->new();
+
+ is( $obj->length, 0, 'length returns zero' );
+
+ $obj->_string('a');
+ is( $obj->length, 1, 'length returns 1 for new string' );
+
+ throws_ok { $obj->length(42) }
+ qr/Cannot call length with any arguments/,
+ 'length throws an error when an argument is passed';
+
+ $obj->inc;
+ is( $obj->_string, 'b', 'a becomes b after inc' );
+
+ throws_ok { $obj->inc(42) }
+ qr/Cannot call inc with any arguments/,
+ 'inc throws an error when an argument is passed';
+
+ $obj->append('foo');
+ is( $obj->_string, 'bfoo', 'appended to the string' );
+
+ throws_ok { $obj->append( 'foo', 2 ) }
+ qr/Cannot call append with more than 1 argument/,
+ 'append throws an error when two arguments are passed';
+
+ $obj->append_curried;
+ is( $obj->_string, 'bfoo!', 'append_curried appended to the string' );
+
+ throws_ok { $obj->append_curried('foo') }
+ qr/Cannot call append with more than 1 argument/,
+ 'append_curried throws an error when two arguments are passed';
+
+ $obj->_string("has nl$/");
+ $obj->chomp;
+ is( $obj->_string, 'has nl', 'chomped string' );
+
+ $obj->chomp;
+ is(
+ $obj->_string, 'has nl',
+ 'chomp is a no-op when string has no line ending'
+ );
-is( $page->string, '', '... got the default value' );
-is( $page->length_string, 0,'... length is zero' );
+ throws_ok { $obj->chomp(42) }
+ qr/Cannot call chomp with any arguments/,
+ 'chomp throws an error when an argument is passed';
-$page->string('a');
-is( $page->length_string, 1,'... new string has length of one' );
+ $obj->chop;
+ is( $obj->_string, 'has n', 'chopped string' );
-$page->inc_string;
-is( $page->string, 'b', '... got the incremented value' );
+ throws_ok { $obj->chop(42) }
+ qr/Cannot call chop with any arguments/,
+ 'chop throws an error when an argument is passed';
-$page->inc_string;
-is( $page->string, 'c', '... got the incremented value (again)' );
+ $obj->_string('x');
+ $obj->prepend('bar');
+ is( $obj->_string, 'barx', 'prepended to string' );
-$page->append_string("foo$/");
-is( $page->string, "cfoo$/", 'appended to string' );
+ $obj->prepend_curried;
+ is( $obj->_string, '-barx', 'prepend_curried prepended to string' );
-$page->chomp_string;
-is( $page->string, "cfoo", 'chomped string' );
+ $obj->replace( qr/([ao])/, sub { uc($1) } );
+ is(
+ $obj->_string, '-bArx',
+ 'substitution using coderef for replacement'
+ );
-$page->chomp_string;
-is( $page->string, "cfoo", 'chomped is noop' );
+ $obj->replace( qr/A/, 'X' );
+ is(
+ $obj->_string, '-bXrx',
+ 'substitution using string as replacement'
+ );
-$page->chop_string;
-is( $page->string, "cfo", 'chopped string' );
+ throws_ok { $obj->replace( {}, 'x' ) }
+ qr/The first argument passed to replace must be a string or regexp reference/,
+ 'replace throws an error when the first argument is not a string or regexp';
-$page->prepend_string("bar");
-is( $page->string, 'barcfo', 'prepended to string' );
+ throws_ok { $obj->replace( qr/x/, {} ) }
+ qr/The second argument passed to replace must be a string or code reference/,
+ 'replace throws an error when the first argument is not a string or regexp';
-is_deeply( [ $page->match_string(qr/([ao])/) ], ["a"], "match" );
+ $obj->_string('Moosex');
+ $obj->replace_curried;
+ is( $obj->_string, 'MooseX', 'capitalize last' );
-$page->replace_string( qr/([ao])/, sub { uc($1) } );
-is( $page->string, 'bArcfo', "substitution" );
-is( $page->length_string, 6, 'right length' );
+ $obj->_string('abcdef');
-$page->exclaim;
-is( $page->string, 'bArcfo!', 'exclaim!' );
+ is_deeply(
+ [ $obj->match(qr/([az]).*([fy])/) ], [ 'a', 'f' ],
+ 'match -barx against /[aq]/ returns matches'
+ );
-$page->string('Moosex');
-$page->capitalize_last;
-is( $page->string, 'MooseX', 'capitalize last' );
+ ok(
+ scalar $obj->match('b'),
+ 'match with string as argument returns true'
+ );
-$page->string('1234');
-ok( !$page->invalid_number, 'string "isn\'t an invalid number' );
+ throws_ok { $obj->match }
+ qr/Cannot call match without at least 1 argument/,
+ 'match throws an error when no arguments are passed';
-$page->string('one two three four');
-ok( $page->invalid_number, 'string an invalid number' );
+ throws_ok { $obj->match( {} ) }
+ qr/The argument passed to match must be a string or regexp reference/,
+ 'match throws an error when an invalid argument is passed';
-$page->clear_string;
-is( $page->string, '', "clear" );
+ $obj->_string('1234');
+ ok( !$obj->match_curried, 'match_curried returns false' );
-# check the meta ..
+ $obj->_string('one two three four');
+ ok( $obj->match_curried, 'match curried returns true' );
-my $string = $page->meta->get_attribute('string');
-does_ok( $string, 'Moose::Meta::Attribute::Native::Trait::String' );
+ $obj->clear;
+ is( $obj->_string, q{}, 'clear' );
-is(
- $string->type_constraint->name, 'Str',
- '... got the expected type constraint'
-);
+ throws_ok { $obj->clear(42) }
+ qr/Cannot call clear with any arguments/,
+ 'clear throws an error when an argument is passed';
-is_deeply(
- $string->handles,
- {
- inc_string => 'inc',
- append_string => 'append',
- prepend_string => 'prepend',
- match_string => 'match',
- replace_string => 'replace',
- chop_string => 'chop',
- chomp_string => 'chomp',
- clear_string => 'clear',
- length_string => 'length',
- exclaim => [ append => '!' ],
- capitalize_last => [ replace => qr/(.)$/, $uc ],
- invalid_number => [ match => qr/\D/ ],
- },
- '... got the right handles methods'
-);
+ $obj->_string('some long string');
+ is(
+ $obj->substr(1), 'ome long string',
+ 'substr as getter with one argument'
+ );
+
+ $obj->_string('some long string');
+ is(
+ $obj->substr( 1, 3 ), 'ome',
+ 'substr as getter with two arguments'
+ );
+
+ $obj->substr( 1, 3, 'ong' );
+
+ is(
+ $obj->_string, 'song long string',
+ 'substr as setter with three arguments'
+ );
+
+ throws_ok { $obj->substr }
+ qr/Cannot call substr without at least 1 argument/,
+ 'substr throws an error when no argumemts are passed';
+
+ throws_ok { $obj->substr( 1, 2, 3, 4 ) }
+ qr/Cannot call substr with more than 3 arguments/,
+ 'substr throws an error when four argumemts are passed';
+
+ throws_ok { $obj->substr( {} ) }
+ qr/The first argument passed to substr must be an integer/,
+ 'substr throws an error when first argument is not an integer';
+
+ throws_ok { $obj->substr( 1, {} ) }
+ qr/The second argument passed to substr must be a positive integer/,
+ 'substr throws an error when second argument is not a positive integer';
+
+ throws_ok { $obj->substr( 1, 2, {} ) }
+ qr/The third argument passed to substr must be a string/,
+ 'substr throws an error when third argument is not a string';
+
+ $obj->_string('some long string');
+
+ is(
+ $obj->substr_curried_1, 'ome long string',
+ 'substr_curried_1 returns expected value'
+ );
+
+ is(
+ $obj->substr_curried_1(3), 'ome',
+ 'substr_curried_1 with one argument returns expected value'
+ );
+
+ $obj->substr_curried_1( 3, 'ong' );
+
+ is(
+ $obj->_string, 'song long string',
+ 'substr_curried_1 as setter with two arguments'
+ );
+
+ $obj->_string('some long string');
+
+ is(
+ $obj->substr_curried_2, 'ome',
+ 'substr_curried_2 returns expected value'
+ );
+
+ $obj->substr_curried_2('ong');
+
+ is(
+ $obj->_string, 'song long string',
+ 'substr_curried_2 as setter with one arguments'
+ );
+
+ $obj->_string('some long string');
+
+ $obj->substr_curried_3;
+
+ is(
+ $obj->_string, 'song long string',
+ 'substr_curried_3 as setter'
+ );
+ }
+ $class;
+}
done_testing;
projects / gitmo/Moose.git / commitdiff