Class::Data::(Inheritable|Accessor)::Lvalueってのをでっち上げた

YappoLogs: LvalueなAccessorのベンチマーク

良く考えたらClass::AccessorのlvalueはあるのにClass::Data::Inheritableのlvalueが無いのがカワイソウな気がしたのでちょっと作ってみた。

package Class::Data::Inheritable::Lvalue;

use strict;
use warnings;
use Carp;

our $VERSION = '0.01';

sub mk_classdata {
    my ($declaredclass, $attribute, $data) = @_;

    if( ref $declaredclass ) {
        croak("mk_classdata() is a class method, not an object method");
    }

    my $coredata = "_${attribute}_coredata_accessor";
    my $accessor = sub : lvalue {
        my $wantclass = ref($_[0]) || $_[0];

        if ( $wantclass ne $declaredclass ) {
            my $lvalue = $wantclass->$coredata;
            $wantclass->mk_classdata($attribute);
            ${ $wantclass->$coredata } = $$lvalue;
        }

        ${ $wantclass->$coredata };
    };

    no warnings qw/redefine/;
    no strict qw/refs/;
    my $alias = "_${attribute}_accessor";
    *{$declaredclass.'::'.$coredata}  = sub { \$data };
    *{$declaredclass.'::'.$attribute} = $accessor;
    *{$declaredclass.'::'.$alias}     = $accessor;
}

1;

正直どうやって実装しようか迷った。

色々考えた末、コアデータにアクセスできる手段を用意してそれを返すようにしたらスッキリきれいに書けたんでそれでやった。

また、本家のモジュールではクラスが別で且つ引数があったときにmk_classdataを呼ぶ処理だったが、lvalueの場合引数が渡されてるかどうかを検知できないので初回時に必ず呼ぶようにした。

一応Class::Accessor::Lvalueがやってるようにtie使えば検知できるが遅いから使いたくないし、WantモジュールのWant::wantassign関数に関してはtieよりもさらに遅くなるので結局こういう形になった。

ってことで完成。

んでまぁClass::Data::Inheritable::Lvalue作るのならClass::Data::Accessor::Lvalueも作ってあげないとカワイソウだよという話なのでそっちも結局作ってみた。

package Class::Data::Accessor::Lvalue;

use strict;
use warnings;
use Carp;

our $VERSION = '0.01';

sub mk_classaccessor {
    my ($declaredclass, $attribute, $data) = @_;

    if( ref $declaredclass ) {
        croak("mk_classaccessor() is a class method, not an object method");
    }

    if( $attribute eq 'DESTROY' ) {
        carp("Having a data accessor named DESTROY in '$declaredclass' is unwise.");
    }

    my $coredata = "_${attribute}_coredata_accessor";
    my $accessor = sub : lvalue {
        my $wantclass = ref($_[0]) || $_[0];

        my $lvalue;
        if (ref $_[0]) {
            $_[0]->{$attribute} = ${$wantclass->$coredata} unless exists $_[0]->{$attribute};
            $lvalue = \$_[0]->{$attribute};
        }
        else {
            if ( $wantclass ne $declaredclass ) {
                $lvalue = $wantclass->$coredata;
                $wantclass->mk_classaccessor($attribute);
                ${ $wantclass->$coredata } = $$lvalue;
            }
            $lvalue = $wantclass->$coredata;
        }
        
        $$lvalue;
    };

    no warnings qw/redefine/;
    no strict qw/refs/;
    my $alias = "_${attribute}_accessor";
    *{$declaredclass.'::'.$coredata}  = sub { \$data };
    *{$declaredclass.'::'.$attribute} = $accessor;
    *{$declaredclass.'::'.$alias}     = $accessor;
}

sub mk_classaccessors {
    my ($declaredclass, @attributes) = @_;

    foreach my $attribute (@attributes) {
        $declaredclass->mk_classaccessor($attribute);
    }
};

1;

まぁ殆ど一緒だわな。

結局のところlvalueで実装するときってreturnが使えないのでなんだかやりにくいったらありゃしない。

まーもっと良い実装方法があるかもね。

ってことでコミット権もらったらCodeReposにうｐしてみよーかなと思います。