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

Perl に substr という関数があります。文字列を部分的に切り出したり、部分的に置換できる関数です。

典型的な使い方はこんな感じ、

my $s = 'The black cat climbed the green tree';

# 4文字読み飛ばしてから5文字取り出す
my $color = substr $s, 4, 5;
print $color;  # => 'black'

# 14文字読み飛ばしてから7文字分を別の文字列で置換する
substr $s, 14, 7, 'jumped from';
print $s;  # => 'The black cat jumped from the green tree'

さて、Perl 界隈で有名な書籍「初めての Perl」を読んでいたら、この substr 関数について次のように書かれていました。

ここで本当に素晴らしい機能を披露しましょう。
第1引数の文字列が変数であれば、その文字列のうち指定した部分を書き換えることができるのです。

my $string = "Hello, world!";
substr($string, 0, 5) = "Goodbye"; # $string は "Goodbye, world!" になる

「初めての Perl 第7版」 P249 より

...

なんだこれ？？

substr($string, 0, 5) = "Goodbye";

なんだ？？？？

というわけで、substr 関数を代入演算子の左辺値に置くことができるようです。

さっそく弊社の Slack に『substr を左辺に置いて代入できるのヤバくないですか』と投稿したら「Perldoc にもっとカオスな例があったはず」と教えてもらえました。

それがこれです、

3 引数の substr によって返された左辺値は「魔法の弾丸」のように振舞うことに注意してください; これが代入される毎に、元の文字列のどの部分が変更されたかが思い出されます; 例えば:

my $x = '1234';
for (substr($x,1,2)) {
    $_ = 'a'; print $x,"\n";    # prints 1a4
    $_ = 'xyz'; print $x,"\n";    # prints 1xyz4
    $x = '56789';
    $_ = 'pq'; print $x,"\n";    # prints 5pq9
}

perldoc より

？？？

左辺値を上書きすることで第1引数に影響を与えているし、 substr 実行後に 第1引数を上書きすることで左辺値に影響を与えている...？

というわけで今回はこの substr のマジカルな挙動を自分で再実装してみようという試みです。

まずはテストを書こう

substr の挙動を再現したいので、まずは substr に対してテストを書きます。
このように、

gist.github.com

ステップ1 〜ステップ4 に分けてみました。
もちろん substr はこのテストを通ります。この後、自作の関数 my_substr がこのテストをパスするように実装をしていきます。

ステップ1. 部分文字列の取り出し

まずはいちばんシンプルに部分文字列を取り出す実装を書いていきます。

my_substr を実装するにあたって内部的に substr を使うことは許されません。
Perl には配列版の substr のような関数があります。その名も splice 。これを使います。

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;
    }
}

わりと単純な実装ですね。

my @chars = split //, $string; によって文字列を "文字の配列" に分解しています。
'Hello' → ('H', 'e', 'l', 'l', 'o') というように。

それを splice に食わせて、最終的に join '', @sub_chars; で再び文字列に戻して返してあげます。

これにてステップ1のテストはパスしてくれます。

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';
};

ステップ2. 一部を置き換え

substr は第4引数を渡すことで文字列の部分置換ができます。my_substr でも第4引数を渡せるようにしましょう。

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;
    }
}

第4引数として $replacement を受け取るようにしました。

substr は第4引数を渡したとき、第1引数の $string を破壊的に上書きします。
Perl において関数呼び出しは参照渡しになっているので、 $_[0] を上書きしてあげることで呼び出し元の変数をも上書きできます。

※ 注意
Perl において関数呼び出しは参照渡しですが、変数への代入はコピーです。
そのため my ($string) = @_; とすると、暗に @_[0] を $string にコピーすることになります。
わざわざ $_[0] = join '', @chars; と書いているのはそのためで、ここを $string = join '', @chars; としてしまうと呼び出し元の変数を破壊的に上書きすることはできません。

ともかくこれでステップ2のテストもパスしてくれます。

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'                                 , '置き換えられた文字列が返る';
};

ステップ3. 左辺値として使う

さていよいよ my_substr をマジカルにしていきましょう。

普通の関数呼び出しを左辺値に置くと Perl は警告を発します。
このように、

$ perl my_substr.pl
Can't modify non-lvalue subroutine call of &main::my_substr in scalar assignment at my_substr.pl line 00, near "'jumped from';"
Execution of my_substr.pl aborted due to compilation errors.

左辺値に置くことを許可するには lvalue 属性をつけてあげる必要があります。

参考：組み込みの属性 - lvalue

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

    ... (中略) ...
}

すると次なる警告が出ます。

$ perl my_substr.pl
Can't return a temporary from lvalue subroutine at my_substr.pl line 00.

my_substr の中で return join '', @sub_chars; していますが、lvalue 属性をつけた関数では返り値に対して代入が行われ得るために式 join '', @sub_chars を返すのは適切ではないというエラーですね。

なので書き換えてあげます。このように、

sub my_substr : lvalue {
    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 my $substr = 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;
    }
}

return my $substr = join '', @sub_chars; で $substr という変数を定義しつつ返してあげるようにしました。

三度実行するとさらに別の警告が出ます。

$ perl my_substr.pl
Useless assignment to a temporary at my_substr.pl line 00.

はい、return の行で変数を定義して値を代入したところで、その値がどこからも参照されないので意味がないという警告ですね。
それはそう。

この警告から分かるのは「substr の返り値は "普通の値" では意味がない」ということです。
少なくとも値の代入をきっかけに裏側で処理を走らせられるような何かでないとダメですね。

代入演算の裏側に独自の処理を仕込む

代入演算の裏側に独自の処理を仕込むとして、候補に挙がるのは overload か tie でしょう。
結論から言うと今回必要なのは tie です。

tie を使うとオブジェクト変数をスカラーコンテキストで扱った時の挙動をカスタマイズできるようになります。
今回カスタムするのは変数への代入 STORE と変数の読み出し FETCH です。

手始めに全く意味のない処理を仕込んで tie してみましょう。

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";
    }
}

このようなクラスを作ります。
そして my_substr の中で tie した値を返します。

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
    }
}

実行すると先ほどまでの Useless assignment to a temporary という警告は出なくなり、代わりに "TIESCALAR", "STORE" が印字されるようになります。

MySubstrLeft を作り込む

というわけで MySubstrLeft クラスを実装していきましょう。
あれこれやってこのようになりました。

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;
    }
}

FETCH されるとき, STORE されるときにそれぞれ substr 相当のことをしています。
そのおかげで my_substr の実行後に 変数を上書きしても動作するようになります。

さらに my_substr の左辺値に代入したときに第1引数の $string に影響を与えなければいけません。
そのために MySubstrLeft の中で $string の参照を保持するようにしています。$string_ref というプロパティがそれです。

my_substr の中では \$_[0] を渡しつつ tie してあげます。

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
    }
}

これによって！なんとステップ3とステップ4どちらのテストもパスするようになりました！

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';
    }
};

まとめ

というわけで substr のマジカルな挙動は lvalue, tie, 参照の上書きが複雑に連携して動いていたんですね。
ホント頭おかしなるで。

私からは以上です。

おまけ

今回書いたコードを置いておきます。

enjoy!

無駄と文化

実用的ブログ