Devel::Declare を使ってみた

最近ちょっと話題になってた Devel::Declare を触ってみました。
POD に書いてあることを素直に行っていくと、例えばですが Perl の文法が普通は許さないこんなプログラムが書けるようになります。method という語でメソッド定義は、普通の Perl ではできないですし、よくある my $self = shift; なんてのも隠蔽されてます。

package UseMyMethods;
use strict;
use warnings;
use My::Methods;

method new {
    my $class = ref $self || $self;
    return bless { @_ }, $class;
}

method foo ($foo) {
    return (ref $self) . ': Foo: ' . $foo;
}

1;

Devel::Declare は XS を使っていて、ぼくは XS を読めないもんだから実装方式は分かっていないのですが、POD に載っているソースはこのモジュールを "使う" という点に関しては非常に分かりやすい例になっています。
Devel::Declare を使うときの基本的な考え方は、上記のような Perl の文法が通常許さないようなソースを、Perl の文法が許す形に書き換えることで、それをするためには割と泥臭いこと(字句解析とほぼ同じようなこと)から行わないといけません。この部分をカプセル化する Devel::Declare::Context::Simple なんてのも付属されてますが、POD の例ではこのあたりを自分で実装します。
というわけで、上掲のプログラムがきちんど動作するためには、以下のようなコードを書きます。POD の例はテスト用の method.t から引っ張っているので、そちらを見ても良いかもしれないですね。

package My::Methods;
use strict;
use warnings;
use Devel::Declare;
use B::Hooks::EndOfScope;

our ($Declarator, $Offset);

sub import {
    my $class  = shift;
    my $caller = caller;

    Devel::Declare->setup_for(
        $caller,
        { method => { const => \&parser } },
    );
    no strict 'refs';
    *{$caller . "::method"} = sub (&) {};
}

sub skipspace {
    $Offset += Devel::Declare::toke_skipspace( $Offset );
}

sub skip_declarator {
    $Offset += Devel::Declare::toke_move_past_token($Offset);
}

sub strip_name {
    skipspace;
    if ( my $len = Devel::Declare::toke_scan_word( $Offset, 1 ) ) {
        my $linestr = Devel::Declare::get_linestr();
        my $name    = substr( $linestr, $Offset, $len );
        substr( $linestr, $Offset, $len ) = '';
        Devel::Declare::set_linestr( $linestr );
        return $name;
    }
    return;
}

sub strip_proto {
    skipspace;

    my $linestr = Devel::Declare::get_linestr;
    if ( substr( $linestr, $Offset, 1 ) eq '(') {
        my $length = Devel::Declare::toke_scan_str( $Offset );
        my $proto  = Devel::Declare::get_lex_stuff();
        Devel::Declare::clear_lex_stuff();
        $linestr = Devel::Declare::get_linestr;
        substr( $linestr, $Offset, $length ) = '';
        Devel::Declare::set_linestr( $linestr );
        return $proto;
    }
    return '';
}

sub make_proto_unwrap {
    my ($proto) = @_;
    my $inject = 'my ($self';
    if (defined $proto) {
        $inject .= ", $proto" if length( $proto );
        $inject .= ') = @_; ';
    } else {
        $inject .= ') = shift;';
    }
    return $inject;
}

sub inject_if_block {
    my $inject = shift;
    skipspace;
    my $linestr = Devel::Declare::get_linestr;
    if ( substr( $linestr, $Offset, 1 ) eq '{' ) {
        substr( $linestr, $Offset + 1, 0 ) = $inject;
        Devel::Declare::set_linestr( $linestr );
    }
}

sub inject_scope {
    on_scope_end {
        my $linestr = Devel::Declare::get_linestr;
        my $offset  = Devel::Declare::get_linestr_offset;
        substr( $linestr, $offset, 0 ) = ';';
        Devel::Declare::set_linestr( $linestr );
    }
}

sub scope_injector_call {
    return ' BEGIN { My::Methods::inject_scope }; ';
}

sub shadow {
    my $pack = Devel::Declare::get_curstash_name;
    Devel::Declare::shadow_sub( "${pack}::${Declarator}", $_[0]);
}

sub parser {
    local ($Declarator, $Offset) = @_;
    skip_declarator;
    my $name  = strip_name;
    my $proto = strip_proto;

    my $inject = make_proto_unwrap( $proto );
    if ( defined $name ) {
        $inject = scope_injector_call() . $inject;
    }
    inject_if_block($inject);

    if ( defined $name ) {
        $name = join('::' => Devel::Declare::get_curstash_name, $name )
            unless $name =~ /::/;
        shadow( sub (&) { no strict 'refs'; *{$name} = shift; } );
    } else {
        shadow( sub (&) { shift } );
    }
}

1;