Class::Accessor::Grouped - 日向夏特殊応援部隊

Class::Accessor::GroupedはDBIx::Classの親クラスの一つです。*1
DBIx::Classを理解する上で避けれないので調べてみました。

要約

簡単に言えばあるクラスのインスタンスが他のクラスのインスタンスを持つような場合に、その他のクラスのアクセサへのショートカットを簡単に作る為のモジュールと言えます。

具体的に言うと、

Foo::Bと言うクラスはa1, a2, a3と言うアクセサを持つ
Foo::AはFoo::Bをアクセサに持ちつつ、Foo::Bのアクセサa1, a2, a3へ直接アクセスするアクセサも持つ

みたいなケースで使えます。

使い方

make_group_accessors()でラベルとショートカットメソッドを登録する
set_component_class()でラベルに対してオブジェクトを突っ込む(この場合はFoo::B, インスタンスを$bだとする)
Foo::Aをインスタンス化 ($aにぶち込む)
$a->b1は$b->b1と同じ事

って事です。

コードに落とすとこんな感じ。

#!/usr/bin/perl

package Foo::B;

use base qw(Class::Accessor::Fast);
__PACKAGE__->mk_accessors(qw/b1 b2 b3/);

package Foo::A;

use base qw(Class::Accessor::Fast Class::Accessor::Grouped);
__PACKAGE__->mk_group_accessors('b', qw/b1 b2 b3/);
__PACKAGE__->mk_accessors(qw/b/);

{
    no strict 'refs';
    sub set_b {
        my ($self, $name, $value) = @_;
        $self->b->$name($value);
    }
    sub get_b {
        my ($self, $name) = @_;
        $self->b->$name();
    }
}

package main;

use Data::Dump qw(dump);

my $b = Foo::B->new({b1 => 1, b2 => 2, b3 => 3});
my $a = Foo::A->new();

$a->set_component_class('b', $b);

$a->b1(10);

print $b->b1;

$bのb1も10になってます。

詳しく説明

mk_group_accessors($group, @fields)

ここはグループ名を決めて、そのグループ名をsuffixに持つget_/set_アクセサがある前提で@fieldsにあるメソッドを本体に生やします。
ちょっと長いけど、適宜僕の方でコメントを入れました。

sub mk_group_accessors {
  my ($self, $group, @fields) = @_;

  $self->_mk_group_accessors('make_group_accessor', $group, @fields);
  return;
}


{
    no strict 'refs';
    no warnings 'redefine';

    sub _mk_group_accessors {
        my($self, $maker, $group, @fields) = @_; # $makerにはmake_group_accessorが入る
        my $class = Scalar::Util::blessed $self || $self;

        # So we don't have to do lots of lookups inside the loop.
        $maker = $self->can($maker) unless ref $maker; 

        foreach my $field (@fields) {
            if( $field eq 'DESTROY' ) {
                Carp::carp("Having a data accessor named DESTROY  in ".
                             "'$class' is unwise.");
            }

            my $name = $field;

            ($name, $field) = @$field if ref $field;

            my $accessor = $self->$maker($group, $field); # 最終的に$group, $fieldでmake_group_accessorを叩いてアクセサを作る
            my $alias = "_${name}_accessor";

            *{$class."\:\:$name"}  = $accessor; # そのアクセサを名前付けて突っ込む
              #unless defined &{$class."\:\:$field"}

            *{$class."\:\:$alias"}  = $accessor; # aliasも作る
              #unless defined &{$class."\:\:$alias"}
        }
    }
}

と言う流れですね。@fieldsの各要素がリファレンスでも良い事になってるのはまぁ置いといて、make_group_accessorを見てみます。

make_group_accessor($group, $field)

まぁ最終的にCODEREFを返すんだけど、set_$group, get_$groupに依存したアクセサを作ってるのはコードを見ればすぐ分かりますね。

sub make_group_accessor {
    my ($class, $group, $field) = @_;

    my $set = "set_$group";
    my $get = "get_$group";

    # eval for faster fastiness
    return eval "sub {
        if(\@_ > 1) {
            return shift->$set('$field', \@_);
        }
        else {
            return shift->$get('$field');
        }
    };"
}

つまり、

package Foo;

use base qw(Class::Accessor::Grouped);
__PACKAGE__->mk_group_accessors('base', qw/id name/);

とかやった場合、set_base/get_baseがある前提でそれに依存したid, nameと言うアクセサがFooに生えるよって事ですね。
但しset_base/get_baseってのは最初からある訳じゃないので、自分で作らないとダメ。これは先のサンプルコードでもやった通りです。
ただ、それじゃ面倒なんで、set_inherited/get_inheritedってメソッドは最初からあって、inheritedグループに突っ込むと由なにやってくれます。

set_inherited($field, $new_value)/get_inherited($field)

えーっと、ここはちと難しい。set_inherited($field, $new_value)の方からですが、

sub set_inherited {
    if (Scalar::Util::blessed $_[0]) {
        if (Scalar::Util::reftype $_[0] eq 'HASH') {
            return $_[0]->{$_[1]} = $_[2];
        } else {
            Carp::croak('Cannot set inherited value on an object instance that is not hash-based');
        };
    } else {
        no strict 'refs';

        return ${$_[0].'::__cag_'.$_[1]} = $_[2];
    };
}

まずはインスタンスメソッドとしてコールされた場合で、そのインスタンスがHASHREFをblessしてる場合は、そのキーにフィールド名$field、値に$new_valueを突っ込みます。
逆にクラスメソッドの場合は、"__cag_$field"と言う名前のパッケージ変数があると見なして突っ込みます。

次にget_inherited($field)の方ですが、

sub get_inherited {
    my $class;

    if (Scalar::Util::blessed $_[0]) { ### インスタンスメソッドとして呼ばれた時
        my $reftype = Scalar::Util::reftype $_[0];
        $class = ref $_[0];

        if ($reftype eq 'HASH' && exists $_[0]->{$_[1]}) { ### blessされたHASHREFにそのフィールドが存在する場合はそのままその値を返す
            return $_[0]->{$_[1]};
        } elsif ($reftype ne 'HASH') { ### HASHREFじゃない場合は怒られる
            Carp::croak('Cannot get inherited value on an object instance that is not hash-based');
        };
    } else { ### クラスメソッドとして呼ばれた時
        $class = $_[0];
    };

    ### 結果的にそのフィールドが存在しない場合もここに辿り着く
    no strict 'refs';
    return ${$class.'::__cag_'.$_[1]} if defined(${$class.'::__cag_'.$_[1]}); ### ___cag_$fieldがあればその値を返す

    if (!@{$class.'::__cag_supers'}) { ### __cag_supersと言う配列が無い場合
        @{$class.'::__cag_supers'} = $_[0]->get_super_paths; ### get_super_pathsで自分の親クラス一覧を取って来る
    };

    foreach (@{$class.'::__cag_supers'}) {
        return ${$_.'::__cag_'.$_[1]} if defined(${$_.'::__cag_'.$_[1]}); ### 最初に見つかった__cag_$fieldの値を返す
    };

    return undef;
}

後半ややこしいですね。ちなみにget_super_pathsはClass::Accessor::Groupedのメソッドで、

sub get_super_paths {
    my $class = Scalar::Util::blessed $_[0] || $_[0];

    return @{mro::get_linear_isa($class)};
};

と言う実装。
mroと言うpackageはMRO::Compatをuseすると使えます。get_linear_isa()はメソッド探索順に継承しているpackageを返します。

まぁこのset_inherited/get_inheritedを簡単にまとめると、

インスタンスメソッドの場合はHASHREF前提で、そのフィールド名のキーがblessされたHASHREFに存在する事が前提
クラスメソッドの場合は"__cag_$field"と言うpackage変数が存在する事が(継承ツリーのどっかにある事が)前提*2

って事になります。

ただ、最初に挙げたサンプルとはちょっと違う使い方になりそう。
と言うのもDBICではクラスメソッドとしてinheritedを利用してるんですが、これってクラス変数的なノリで使ってるのかなーと推察。
でC3の探索順に合わせんが為にget_super_paths()があるのかなと予想。

なんか全然まとまりないな＞＜

*1:もう一個はDBIx::Class::Componentised

*2:これがinheritedと言う所以かな、多分