From: Dave Rolsky <autarch@urth.org>
Date: Mon, 20 Sep 2010 17:31:56 +0000 (-0500)
Subject: Implemented inlning for all string methods.
X-Git-Tag: 1.15~132
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e7724627674e5f80d9318fb39cf8976fbe2f837b;p=gitmo%2FMoose.git

Implemented inlning for all string methods.

Lots of refactoring to existing native trait inlining code to share more between different types.
---

diff --git a/lib/Moose/Meta/Attribute/Native/MethodProvider/String.pm b/lib/Moose/Meta/Attribute/Native/MethodProvider/String.pm
deleted file mode 100644
index d761f8b..0000000
--- a/lib/Moose/Meta/Attribute/Native/MethodProvider/String.pm
+++ /dev/null
@@ -1,147 +0,0 @@
-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
diff --git a/lib/Moose/Meta/Attribute/Native/Trait/String.pm b/lib/Moose/Meta/Attribute/Native/Trait/String.pm
index e9313eb..341a3b6 100644
--- a/lib/Moose/Meta/Attribute/Native/Trait/String.pm
+++ b/lib/Moose/Meta/Attribute/Native/Trait/String.pm
@@ -5,21 +5,25 @@ our $VERSION   = '1.14';
 $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;
diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/count.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/count.pm
index 36c8de4..aeb67d7 100644
--- a/lib/Moose/Meta/Method/Accessor/Native/Array/count.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/Array/count.pm
@@ -12,8 +12,7 @@ use base 'Moose::Meta::Method::Accessor::Native::Array::Reader';
 sub _maximum_arguments { 0 }
 
 sub _return_value {
-    my $self        = shift;
-    my $slot_access = shift;
+    my ( $self, $slot_access ) = @_;
 
     return "scalar \@{ $slot_access }";
 }
diff --git a/lib/Moose/Meta/Method/Accessor/Native/Reader.pm b/lib/Moose/Meta/Method/Accessor/Native/Reader.pm
index 3304cae..5bc0a28 100644
--- a/lib/Moose/Meta/Method/Accessor/Native/Reader.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/Reader.pm
@@ -18,21 +18,36 @@ sub _generate_method {
     $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 ) = @_;
 
diff --git a/lib/Moose/Meta/Method/Accessor/Native/String.pm b/lib/Moose/Meta/Method/Accessor/Native/String.pm
new file mode 100644
index 0000000..3cdf6f5
--- /dev/null
+++ b/lib/Moose/Meta/Method/Accessor/Native/String.pm
@@ -0,0 +1,10 @@
+package Moose::Meta::Method::Accessor::Native::String;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.13';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+1;
diff --git a/lib/Moose/Meta/Method/Accessor/Native/String/Reader.pm b/lib/Moose/Meta/Method/Accessor/Native/String/Reader.pm
new file mode 100644
index 0000000..70084b1
--- /dev/null
+++ b/lib/Moose/Meta/Method/Accessor/Native/String/Reader.pm
@@ -0,0 +1,15 @@
+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;
diff --git a/lib/Moose/Meta/Method/Accessor/Native/String/Writer.pm b/lib/Moose/Meta/Method/Accessor/Native/String/Writer.pm
new file mode 100644
index 0000000..8293e91
--- /dev/null
+++ b/lib/Moose/Meta/Method/Accessor/Native/String/Writer.pm
@@ -0,0 +1,67 @@
+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;
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..0c31f30
--- /dev/null
+++ b/lib/Moose/Meta/Method/Accessor/Native/String/append.pm
@@ -0,0 +1,21 @@
+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;
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..df69b61
--- /dev/null
+++ b/lib/Moose/Meta/Method/Accessor/Native/String/chomp.pm
@@ -0,0 +1,32 @@
+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;
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..b6a9a24
--- /dev/null
+++ b/lib/Moose/Meta/Method/Accessor/Native/String/chop.pm
@@ -0,0 +1,32 @@
+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;
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..2acebea
--- /dev/null
+++ b/lib/Moose/Meta/Method/Accessor/Native/String/clear.pm
@@ -0,0 +1,32 @@
+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;
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..156575a
--- /dev/null
+++ b/lib/Moose/Meta/Method/Accessor/Native/String/inc.pm
@@ -0,0 +1,32 @@
+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;
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..c73238d
--- /dev/null
+++ b/lib/Moose/Meta/Method/Accessor/Native/String/length.pm
@@ -0,0 +1,21 @@
+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;
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..00996bd
--- /dev/null
+++ b/lib/Moose/Meta/Method/Accessor/Native/String/match.pm
@@ -0,0 +1,29 @@
+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;
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..2a115b2
--- /dev/null
+++ b/lib/Moose/Meta/Method/Accessor/Native/String/prepend.pm
@@ -0,0 +1,21 @@
+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;
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..76880cf
--- /dev/null
+++ b/lib/Moose/Meta/Method/Accessor/Native/String/replace.pm
@@ -0,0 +1,44 @@
+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;
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..0a43e8a
--- /dev/null
+++ b/lib/Moose/Meta/Method/Accessor/Native/String/substr.pm
@@ -0,0 +1,109 @@
+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;
diff --git a/lib/Moose/Meta/Method/Accessor/Native/Writer.pm b/lib/Moose/Meta/Method/Accessor/Native/Writer.pm
index 60b672d..39a6f68 100644
--- a/lib/Moose/Meta/Method/Accessor/Native/Writer.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/Writer.pm
@@ -17,25 +17,37 @@ sub _generate_method {
     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,
@@ -44,19 +56,13 @@ sub _generate_method {
 
     $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;
 }
@@ -67,9 +73,13 @@ sub _inline_check_arguments {q{}}
 
 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;
@@ -79,7 +89,9 @@ sub _inline_check_constraint {
     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{} }
 
@@ -89,6 +101,6 @@ sub _inline_set_new_value {
     return $self->SUPER::_inline_store(@_);
 }
 
-sub _return_value      { return q{} }
+sub _return_value { return q{} }
 
 1;
diff --git a/t/070_native_traits/005_trait_string.t b/t/070_native_traits/005_trait_string.t
index 2f3bae9..f76783e 100644
--- a/t/070_native_traits/005_trait_string.t
+++ b/t/070_native_traits/005_trait_string.t
@@ -3,115 +3,268 @@
 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;