このアーカイブは同期化されません。 mixi の日記が更新されても、このアーカイブには反映されません。
さて、今日で完成としよう。
必要な機能は、引数無しで指定した場合、
自動的にシンボルテーブルのメソッドを調べることだ。
ただ、モジュールが use された直後ではまずい。
use は、暗黙的に BEGIN ブロックで実行されるため、
定義されているメソッドが読み込まれる前に実行される。
そのため import 内で対象のシンボルテーブルを検索しても、
シンボルテーブルにはまだメソッドが定義されていない。
対策として、import ではパッケージ名だけ記憶しておき、
シンボルテーブルの検索は後で行えばよい。
では、「後」とはどのタイミングか。
Perl には、このような状況に最適な、
CHECK ブロックというものがある。
CHECK は BEGIN の逆のような役割を持ち、
通常のコードが実行される「直前」に実行される。
つまり、コンパイルフェーズの最後に実行される。
これを使えば、他のモジュールによって、
パッケージに動的にメソッドが追加されても、
それらを含めてメソッドを検索できるようになる。
後はモジュールの引数のチェックや、
既にメソッドが存在していた場合に上書きしないように
各種チェックを追加すればよい。
========== property.pm ==========
package property;
use v5.6.0;
use strict;
use warnings;
use Carp;
my @Targets = ();
BEGIN {
our $Version = '1.00';
}
sub import {
my ($package, @params) = @_;
my $target = caller;
_trust_me($target);
# 引数がない場合、後でパッケージを検索。
if (@_ == 1) {
push(@Targets, $target);
return;
}
foreach my $param (@params) {
# $param 引数がスカラの場合推測する。
if (ref $param eq '') {
$param = {
'name' => "$param",
'get' => "get_$param",
'set' => "set_$param",
};
}
# プロパティ名のチェック。
croak 'Property name not specified.'
if not defined $param->{'name'}
or length $param->{'name'} == 0;
# プロパティの登録。
_create_property($target, $param->{'name'},
$param->{'get'}, $param->{'set'});
}
}
CHECK {
# シンボルテーブルを検索して動的に追加。
foreach my $target (@Targets) {
# シンボルテーブルを得る。
no strict 'refs';
my $symbol_table = \%{"${target}::"};
use strict 'refs';
# メソッド名を得る。
my @methods = grep {
ref \$symbol_table->{$_} eq 'GLOB'
and defined *{$symbol_table->{$_}}{'CODE'};
} keys %$symbol_table;
# set_XXX, get_XXX を見つけ出し、XXX を得る。
my %uniq;
my @properties =
grep { ++$uniq{$_} == 1 }
map { /^[g|s]et_(\w+)$/ ? $1 : () }
@methods;
undef %uniq;
# XXX をプロパティとして登録する。
_create_property($target, $_, "get_$_", "set_$_")
foreach @properties;
}
}
# 対象に対して Carp の信頼基盤を有効にする。
sub _trust_me {
my ($target) = @_;
my $symbol = "${target}::CARP_NOT";
no strict 'refs';
no warnings;
push(@$symbol, __PACKAGE__)
if grep { $_ eq __PACKAGE__ } @$symbol;
}
# プロパティを登録する。
sub _create_property {
my ($package, $name, $get, $set) = @_;
my $propertizer = sub : lvalue {
my $this = shift;
tie(my $reflector, __PACKAGE__, $this, $get, $set);
$reflector;
};
_register_code($package, $name, $propertizer);
}
# パッケージにコードを登録する。
sub _register_code {
my ($package, $name, $code) = @_;
my $symbol = "${package}::${name}";
no strict 'refs';
# 既に存在していた場合は警告。
if (defined *$symbol{'CODE'}) {
carp "Subroutine $name already exists in package $package.";
return;
}
*$symbol = $code;
}
# lvalue マジカルスカラ用の tie 実装。
sub TIESCALAR {
my ($package, $object, $get, $set) = @_;
$package = (ref $package or $package or __PACKAGE__);
my $this = { 'object' => $object, 'get' => $get, 'set' => $set };
bless($this, $package);
}
# プロパティ値の取得。
sub FETCH {
my $this = $_[0];
my $object = $this->{'object'};
my $method = $this->{'get'};
my $code = $method and $object->can($method);
# getter が呼び出せない場合は書き込み専用。
croak "Can't get value to this property."
if not defined $code;
$object->$code();
}
# プロパティ値の代入。
sub STORE {
my ($this, $value) = @_;
my $object = $this->{'object'};
my $method = $this->{'set'};
my $code = $method and $object->can($method);
# setter が呼び出せない場合は読み取り専用。
croak "Can't set value to this property."
if not defined $code;
$object->$code($value);
}
1;
========== end of property.pm ==========