さぁ!use ttに触れよう!

Module::Compileを利用したttモジュールですが、なんかDBIx::Class::StorageReadOnlyとか見てたら実践投入されてたりして、もしかしたらこの先バリバリ使われていくのかなぁ?とか思って僕もちょっと触ってみた。

例題ってことでアクセサを作ってみた。

package Hoge;
use strict;
use warnings;

use tt (accessors => [qw/name address mail/]);
[% FOR accessor IN accessors %]
sub [% accessor %] {
    my $self = shift;
    $self->{q{[% accessor %]}} = shift if @_;
    $self->{q{[% accessor %]}};
}
[% END %]
no tt;

sub new { bless {} , shift }

my $obj = Hoge->new;
print $obj->name('ore');

ほうほう、ちゃんと生成されとるね。なかなかいいんじゃまいですか?

ただコレだけじゃ面白くもなんともないので実装部分を外部ファイルにするってのはどうかと思い、

use tt (accessors => [qw/name address mail/]);
[% INCLUDE 'tt/accessors.tt' %]
no tt;

sub new { bless {} , shift }

my $obj = Hoge->new;
print $obj->name('ore');

こうしてみた。INCLUDEパスに@INCが追加されてるのでINC以下にttディレクトリ作ってaccessors.ttを置いておけばOK。

でもうちょい隠蔽してみようと思って色々考えてみて、

use tt::accessors qw/name address mail/;
[% INCLUDE $tt %]
no tt;

とか書けたら便利かなぁとか。

tt::accessorsの実装は

package tt::accessors;
use strict;
use warnings;
use base qw/tt/;

sub pmc_compile {
    my ( $class, $source, $extra ) = @_;
    
    my @accessors = do {
        ( my $vars = $extra->{use} ) =~ s/^\s*use\s+tt::accessors\s*//;
        eval "$vars";
    };
    
    $extra->{use} = sprintf q{use tt (accessors => [qw/%s/],tt => 'tt/accessors.tt');} , join ' ', @accessors;
    
    $class->SUPER::pmc_compile($source,$extra);
}

1;

こんな感じ。

んでコレをaccessorだけじゃなくてもっと汎用的にでけんかと考えてtt::baseを考案。

package tt::base;
use strict;
use warnings;
use base qw/tt/;
use Data::Dumper ();

sub use_vars {
    my ( $class,$extra ) = @_;
    my @use_vars = do {
        ( my $vars = $extra->{use} ) =~ s/^\s*use\s+tt::[^\s]+\s*//;
        eval "$vars";
    };
    die "error evaluating vars on use line ($extra->{use}): $@"
        if $@;
    return @use_vars;
}

sub pmc_compile {
    my ( $class, $source, $extra ) = @_;
    
    ( my $include_file = $class ) =~ s{::}{/}g;
    $include_file .= '.tt';
    
    my $vars;
    if ( $extra->{use_vars} ) {
        $vars = Data::Dumper::Dumper($extra->{use_vars});
        $vars =~ s/^\$VAR1 = {/(/;
        $vars =~ s/};$/)/;
    }
    else {
        $vars = { $class->use_vars($extra) };
    }
    
    $extra->{use} = sprintf q{use tt (tt => '%s',%s);} ,$include_file,$vars;
    
    $class->SUPER::pmc_compile($source,$extra);
}

1;

でtt::accessorsもtt::baseを利用するように変更

package tt::accessors;
use strict;
use warnings;
use base qw/tt::base/;

sub pmc_compile {
    my ( $class, $source, $extra ) = @_;
    my @accessors = $class->use_vars($extra);
    $extra->{use_vars} = { accessors => \@accessors };
    $class->SUPER::pmc_compile($source,$extra);
}

1;

とまぁこんな感じで終了。

色々触ってみたけど面白いね。

use ttで何かを実装しようとおもったら普段とまったく違う考え方でプログラム組まなきゃならないね。頭を切り替えるのが難いorz

あとアクセサぐらいClass::Accessorとかでいいじゃん!ってのも確かにそうなんだけど若干の違いとして

Class::Accessorはクロージャと型グロブでメソッド上書きしてるだけなんで厳密に言うとそのパッケージのメソッドにならない。

一方use ttを使った場合はメソッドを焼き付けるのでそのパッケージの所有物になる。

これらの違いは普段は気にすることはないが、例えばUNIVERSAL::whichなどを使ったときに

 # Class::Accessorの場合
 print scalar $obj->which('name'); # Class::Accessor::__ANON__

 # use ttの場合
 print scalar $obj->which('name'); # Hoge::name

というようになる。

ってかUNIVERSAL::whichで思い出したけどまだ弾さんにバグ報告してなかったorz

あとで連絡してみよう。