substr のマジカルな挙動を再現したい

my_substr.pl

use strict;
use warnings;
use Test::More;

package MySubstrLeft {
    sub TIESCALAR {
        my ($class, $string_ref, $offset, $length) = @_;

        my $string = $$string_ref;
        $offset = $offset < 0 ? length($string) + $offset          : $offset;
        $length = $length > 0 ? $length + $offset - length($string): $length;

        return bless {
            string_ref => $string_ref,
            offset     => $offset,
            length     => $length,
        }, $class;
    }

    sub FETCH {
        my ($self) = @_;

        my @chars = split //, $self->{string_ref}->$*;
        my @sub_chars = splice @chars, $self->{offset}, $self->{length};

        return join '', @sub_chars;
    }

    sub STORE {
        my ($self, $replacement) = @_;

        my @chars = split //, $self->{string_ref}->$*;
        my @replacement_chars = split //, $replacement;
        splice @chars, $self->{offset}, $self->{length}, @replacement_chars;

        $self->{string_ref}->$* = join '', @chars;
    }
}

sub my_substr : lvalue {
    my ($str, $offset, $length, $replacement) = @_;
    my @chars = split //, $str;

    if (scalar @_ == 2) {
        my @sub_chars = splice @chars, $offset;
        my $substr = join '', @sub_chars;
        return $substr
    } elsif (scalar @_ == 3) {
        tie my $substr, 'MySubstrLeft', \$_[0], $offset, $length;
        return $substr;
    } else {
        my @replacement_chars = split //, $replacement;
        my @sub_chars = splice @chars, $offset, $length, @replacement_chars;
        $_[0] = join '', @chars;
        my $substr = join '', @sub_chars;
        return $substr
    }
}

subtest 'ステップ1. 部分文字列を取り出し' => sub {
    my $s = 'The black cat climbed the green tree';

    my $color = my_substr $s, 4, 5;
    is $color, 'black';

    my $middle = my_substr $s, 4, -11;
    is $middle, 'black cat climbed the';

    my $end = my_substr $s, 14;
    is $end, 'climbed the green tree';

    my $tail = my_substr $s, -4;
    is $tail, 'tree';

    my $z = my_substr $s, -4, 2;
    is $z, 'tr';
};

subtest 'ステップ2. 一部を置き換え' => sub {
    my $s = 'The black cat climbed the green tree';
    my $z = my_substr $s, 14, 7, 'jumped from';
    is $s, 'The black cat jumped from the green tree', '元の文字列は置き換わる';
    is $z, 'climbed'                                 , '置き換えられた文字列が返る';
};

subtest 'ステップ3. 左辺値として使う' => sub {
    my $s = 'The black cat climbed the green tree';
    my_substr($s, 14, 7) = 'jumped from';
    is $s, 'The black cat jumped from the green tree', '元の文字列は置き換わる';
};

subtest 'ステップ4. 魔法の弾丸' => sub {
    my $x = '1234';
    for (substr $x, 1, 2) {
        is $_, '23';

        $_ = 'a';
        is $x, '1a4';

        $_ = 'xyz';
        is $x, '1xyz4';

        $x = '56789';
        $_ = 'pq';
        is $x, '5pq9';
    }

    my $y = '1234';
    for (substr($y, -3, 2)) {
        $_ = 'a';
        is $y, '1a4';

        $y = 'abcdefg';
        is $_, 'f';
    }
};

done_testing;

my_substr_v1.pl

use strict;
use warnings;
use Test::More;

sub my_substr {
    my ( $string, $offset, $length ) = @_;
    my @chars = split //, $string;

    if ( scalar @_ == 2 ) {
        my @sub_chars = splice @chars, $offset;
        return join '', @sub_chars;
    }
    else {
        my @sub_chars = splice @chars, $offset, $length;
        return join '', @sub_chars;
    }
}

subtest 'ステップ1. 部分文字列を取り出し' => sub {
    my $s = 'The black cat climbed the green tree';

    my $color = my_substr $s, 4, 5;
    is $color, 'black';

    my $middle = my_substr $s, 4, -11;
    is $middle, 'black cat climbed the';

    my $end = my_substr $s, 14;
    is $end, 'climbed the green tree';

    my $tail = my_substr $s, -4;
    is $tail, 'tree';

    my $z = my_substr $s, -4, 2;
    is $z, 'tr';
};

done_testing;

my_substr_v2.pl

use strict;
use warnings;
use Test::More;

sub my_substr {
    my ( $string, $offset, $length, $replacement ) = @_;
    my @chars = split //, $string;

    if ( scalar @_ == 2 ) {
        my @sub_chars = splice @chars, $offset;
        return join '', @sub_chars;
    }
    elsif ( scalar @_ == 3 ) {
        my @sub_chars = splice @chars, $offset, $length;
        return join '', @sub_chars;
    }
    else {
        my @replacement_chars = split //, $replacement;
        my @sub_chars = splice @chars, $offset, $length, @replacement_chars;
        $_[0] = join '', @chars;
        return join '', @sub_chars;
    }
}

subtest 'ステップ1. 部分文字列を取り出し' => sub {
    my $s = 'The black cat climbed the green tree';

    my $color = my_substr $s, 4, 5;
    is $color, 'black';

    my $middle = my_substr $s, 4, -11;
    is $middle, 'black cat climbed the';

    my $end = my_substr $s, 14;
    is $end, 'climbed the green tree';

    my $tail = my_substr $s, -4;
    is $tail, 'tree';

    my $z = my_substr $s, -4, 2;
    is $z, 'tr';
};

subtest 'ステップ2. 一部を置き換え' => sub {
    my $s = 'The black cat climbed the green tree';
    my $z = my_substr $s, 14, 7, 'jumped from';
    is $s, 'The black cat jumped from the green tree', '元の文字列は置き換わる';
    is $z, 'climbed',                                  '置き換えられた文字列が返る';
};

done_testing;

my_substr_v3.pl

use strict;
use warnings;
use Test::More;

package MySubstrLeft {
    sub TIESCALAR {
        my ($class) = @_;
        print "TIESCALAR\n";
        return bless {}, $class;
    }

    sub FETCH {
        my ($self) = @_;
        print "FETCH\n";
        return undef;
    }

    sub STORE {
        my ( $self, $val ) = @_;
        print "STORE\n";
    }
}

sub my_substr : lvalue {
    my ( $str, $offset, $length, $replacement ) = @_;
    my @chars = split //, $str;

    if ( scalar @_ == 2 ) {
        my @sub_chars = splice @chars, $offset;
        my $substr    = join '', @sub_chars;
        return $substr;
    }
    elsif ( scalar @_ == 3 ) {
        my @sub_chars = splice @chars, $offset, $length;
        my $substr    = join '', @sub_chars;
        tie my $t, 'MySubstrLeft';
        return $t;
    }
    else {
        my @replacement_chars = split //, $replacement;
        my @sub_chars = splice @chars, $offset, $length, @replacement_chars;
        $_[0] = join '', @chars;
        my $substr = join '', @sub_chars;
        return $substr;
    }
}

subtest 'ステップ3. 左辺値として使う' => sub {
    my $s = 'The black cat climbed the green tree';
    my_substr( $s, 14, 7 ) = 'jumped from';
    is $s, 'The black cat jumped from the green tree', '元の文字列は置き換わる';
};

done_testing;

my_substr_v4.pl

use strict;
use warnings;
use Test::More;

package MySubstrLeft {
    sub TIESCALAR {
        my ( $class, $string_ref, $offset, $length ) = @_;

        my $string = $$string_ref;
        $offset = $offset < 0 ? length($string) + $offset           : $offset;
        $length = $length > 0 ? $length + $offset - length($string) : $length;

        return bless {
            string_ref => $string_ref,
            offset     => $offset,
            length     => $length,
        }, $class;
    }

    sub FETCH {
        my ($self) = @_;

        my @chars     = split //, $self->{string_ref}->$*;
        my @sub_chars = splice @chars, $self->{offset}, $self->{length};

        return join '', @sub_chars;
    }

    sub STORE {
        my ( $self, $replacement ) = @_;

        my @chars             = split //, $self->{string_ref}->$*;
        my @replacement_chars = split //, $replacement;
        splice @chars, $self->{offset}, $self->{length}, @replacement_chars;

        $self->{string_ref}->$* = join '', @chars;
    }
}

sub my_substr : lvalue {
    my ( $str, $offset, $length, $replacement ) = @_;
    my @chars = split //, $str;

    if ( scalar @_ == 2 ) {
        my @sub_chars = splice @chars, $offset;
        my $substr    = join '', @sub_chars;
        return $substr;
    }
    elsif ( scalar @_ == 3 ) {
        tie my $substr, 'MySubstrLeft', \$_[0], $offset, $length;
        return $substr;
    }
    else {
        my @replacement_chars = split //, $replacement;
        my @sub_chars = splice @chars, $offset, $length, @replacement_chars;
        $_[0] = join '', @chars;
        my $substr = join '', @sub_chars;
        return $substr;
    }
}

subtest 'ステップ1. 部分文字列を取り出し' => sub {
    my $s = 'The black cat climbed the green tree';

    my $color = my_substr $s, 4, 5;
    is $color, 'black';

    my $middle = my_substr $s, 4, -11;
    is $middle, 'black cat climbed the';

    my $end = my_substr $s, 14;
    is $end, 'climbed the green tree';

    my $tail = my_substr $s, -4;
    is $tail, 'tree';

    my $z = my_substr $s, -4, 2;
    is $z, 'tr';
};

subtest 'ステップ2. 一部を置き換え' => sub {
    my $s = 'The black cat climbed the green tree';
    my $z = my_substr $s, 14, 7, 'jumped from';
    is $s, 'The black cat jumped from the green tree', '元の文字列は置き換わる';
    is $z, 'climbed',                                  '置き換えられた文字列が返る';
};

subtest 'ステップ3. 左辺値として使う' => sub {
    my $s = 'The black cat climbed the green tree';
    my_substr( $s, 14, 7 ) = 'jumped from';
    is $s, 'The black cat jumped from the green tree', '元の文字列は置き換わる';
};

subtest 'ステップ4. 魔法の弾丸' => sub {
    my $x = '1234';
    for ( substr $x, 1, 2 ) {
        is $_, '23';

        $_ = 'a';
        is $x, '1a4';

        $_ = 'xyz';
        is $x, '1xyz4';

        $x = '56789';
        $_ = 'pq';
        is $x, '5pq9';
    }

    my $y = '1234';
    for ( substr( $y, -3, 2 ) ) {
        $_ = 'a';
        is $y, '1a4';

        $y = 'abcdefg';
        is $_, 'f';
    }
};

done_testing;

substr.pl

use strict;
use warnings;
use Test::More;

subtest 'ステップ1. 部分文字列の取り出し' => sub {
    my $s = 'The black cat climbed the green tree';

    my $color = substr $s, 4, 5;
    is $color, 'black';

    my $middle = substr $s, 4, -11;
    is $middle, 'black cat climbed the';

    my $end = substr $s, 14;
    is $end, 'climbed the green tree';

    my $tail = substr $s, -4;
    is $tail, 'tree';

    my $z = substr $s, -4, 2;
    is $z, 'tr';
};

subtest 'ステップ2. 一部を置き換え' => sub {
    my $s = 'The black cat climbed the green tree';
    my $z = substr $s, 14, 7, 'jumped from';
    is $s, 'The black cat jumped from the green tree', '元の文字列は置き換わる';
    is $z, 'climbed'                                 , '置き換えられた文字列が返る';
};

subtest 'ステップ3. 左辺値として使う' => sub {
    my $s = 'The black cat climbed the green tree';
    substr($s, 14, 7) = 'jumped from';
    is $s, 'The black cat jumped from the green tree', '元の文字列は置き換わる';
};

subtest 'ステップ4. 魔法の弾丸' => sub {
    my $x = '1234';
    for (substr $x, 1, 2) {
        is $_, '23';

        $_ = 'a';
        is $x, '1a4';

        $_ = 'xyz';
        is $x, '1xyz4';

        $x = '56789';
        $_ = 'pq';
        is $x, '5pq9';
    }

    my $y = '1234';
    for (substr($y, -3, 2)) {
        $_ = 'a';
        is $y, '1a4';

        $y = 'abcdefg';
        is $_, 'f';
    }
};

done_testing;