さて、今日で完成としよう。

必要な機能は、引数無しで指定した場合、
自動的にシンボルテーブルのメソッドを調べることだ。

ただ、モジュールが 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 ==========