2008-05-19

XRI::Resolution::Liteのサンプル

解説はあとで。

priorityも考慮に入れて、OpenID サービスを取得する場合はこんな感じかなぁ。

#!/usr/bin/perl

use strict;
use warnings;

use Data::Dump qw(dump);

use Math::BigInt;
use Perl6::Say;
use XML::LibXML;
use XRI::Resolution::Lite;

my $claim_id = $ARGV[0];

sub rand_array {
    my @list = @_;
    return 
        map { $_->[0] }
        sort { $a->[1] <=> $b->[1] }
        map { [$_, rand] }
        @list;
}

sub get_services {
    my $claimd_id = shift;
    my $resolution = XRI::Resolution::Lite->new;
    my $xrds = $resolution->resolve($claim_id);

    my $xpc = XML::LibXML::XPathContext->new($xrds);
    $xpc->registerNs('xrd', 'xri://$xrd*($v*2.0)');

    my %services = ();
    my @services =  $xpc->findnodes('//xrd:Type[text() = "http://openid.net/signon/1.0" or text() = "http://openid.net/signon/1.1" or text() = "http://specs.openid.net/auth/2.0/signon"]/ancestor::xrd:Service');

    for my $service (@services) {
        my $priority = int ($service->getAttribute("priority")) || Math::BigInt->binf;
        $services{$priority} = [] unless (exists $services{$priority});
        push(@{$services{$priority}}, $service);
    }

    return
        map { $_->toString }
        map { rand_array(@{$services{$_}}) }
        sort { $a <=> $b }
        keys %services;
}

say dump(get_services($claim_id));

2008-04-15

Catalyst/DBICでDigest認証する

Perl CPAN Catalyst DBIC

自分の為のメモですよ。

準備

まずはCatalystプロジェクトを作ります

$ mkdir -p /path/to/dir
$ cd /path/to/dir
$ catalyst.pl AuthSample

ユーザー用のDBIC スキーマを定義します。

$ module-starter --module AuthSample::Schema
$ cd AuthSample-Schema

でこのディレクトリにて、

CREATE TABLE user (
	user_seq INTEGER PRIMARY KEY,
	user_id TEXT UNIQUE,
	password TEXT,
	created_on DATETIME,
	updated_on DATETIME
);

こんなスキーマを定義して、schema.sqlとして保存して、

$ sqlite3 -init schema.sql authsample.db

として初期化する。

次にスキーマ生成の為の簡易スクリプトをtypesterさんの奴をベースに ./script/schema.pl として作る。

#!/usr/bin/perl

use strict;
use warnings;

use FindBin;
use File::Spec;
use lib (
    File::Spec->catfile( $FindBin::Bin, qw/.. lib/ ),
    File::Spec->catfile( $FindBin::Bin, qw/.. schema/ )
);

use DBIx::Class::Schema::Loader qw(make_schema_at);

die('Required arguments dsn dbuser dbpass') unless (@ARGV);

my $schema_class = 'AuthSample::Schema';

unlink(
    glob(
        File::Spec->catdir( $FindBin::Bin, '..', 'lib',
            split( /::/, $schema_class ) )
            . '/*.pm'
    )
);

make_schema_at(
    $schema_class,
    {   components => [
            qw/ResultSetManager UTF8Columns InflateColumn::DateTime TimeStamp DigestColumns/
        ],
        dump_directory => File::Spec->catfile( $FindBin::Bin, qw/.. lib/ ),
        debug          => 1,
        really_erase_my_files => 0,
    },
    \@ARGV,
);

こんな感じ。改良点は、

各テーブルクラスは自分で自ら消す
really_erase_my_files を 0 にしてるので Schema::Loader 自身は何も消さない
1. つまり Schema クラスは残ったままで、自由に編集出来る

みたいな点。詳しくはCatalystConで話す。

実行権限を与えて、さらに事前にmodule-starterでSchemaクラスが出来ちゃってるからそれを消してからschema.plを実行する。

$ chmod +x ./script/schema.pl
$ rm -f ./lib/AuthSample/Schema.pm
$ ./script/schema.pl dbi:SQLite:dbname=authsample.db

これでひな形は完成。

DBIC関連を今回は手動でちょっと弄る

*** lib/AuthSample/Schema/User.pm.orig	2008-04-15 11:49:27.000000000 +0900
--- lib/AuthSample/Schema/User.pm	2008-04-15 11:54:33.000000000 +0900
***************
*** 5,10 ****
--- 5,13 ----
  
  use base 'DBIx::Class';
  
+ __PACKAGE__->mk_classdata('digest_user_name_column');
+ __PACKAGE__->mk_classdata('digest_realm' => '');
+ 
  __PACKAGE__->load_components(
    "ResultSetManager",
    "UTF8Columns",
***************
*** 20,34 ****
    "user_id",
    { data_type => "TEXT", is_nullable => 0, size => undef },
    "password",
!   { data_type => "TEXT", is_nullable => 0, size => undef },
    "created_on",
!   { data_type => "DATETIME", is_nullable => 0, size => undef },
    "updated_on",
!   { data_type => "DATETIME", is_nullable => 0, size => undef },
  );
  __PACKAGE__->set_primary_key("user_seq");
  __PACKAGE__->add_unique_constraint("user_id_unique", ["user_id"]);
  
  
  # Created by DBIx::Class::Schema::Loader v0.04004 @ 2008-04-15 11:39:32
  # DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:7O29VfwnVCsyZL2avThORA
--- 23,61 ----
    "user_id",
    { data_type => "TEXT", is_nullable => 0, size => undef },
    "password",
!   { data_type => "TEXT", is_nullable => 0, size => undef, digest_check_method => 'check_password' },
    "created_on",
!   { data_type => "DATETIME", is_nullable => 0, size => undef, set_on_create => 1, },
    "updated_on",
!   { data_type => "DATETIME", is_nullable => 0, size => undef, set_on_create => 1, set_on_update => 1 },
  );
  __PACKAGE__->set_primary_key("user_seq");
  __PACKAGE__->add_unique_constraint("user_id_unique", ["user_id"]);
  
+ __PACKAGE__->digestcolumns(
+     columns => [qw/password/],
+     algorithm => 'MD5',
+     encoding => 'hex',
+     auto => 1,
+     dirty => 1,
+ );
+ 
+ __PACKAGE__->digest_user_name_column('user_id');
+ __PACKAGE__->digest_realm('Are you TKSK?');
+ 
+ sub _get_digest_string {
+     my ($self, $value) = @_;
+ 
+     $self->digest_maker->reset;
+ 
+     return $self->next::method(
+         join(':',
+              $self->get_column($self->digest_user_name_column) || '',
+              $self->digest_realm,
+              $value || ''
+          )
+     );
+ }
  
  # Created by DBIx::Class::Schema::Loader v0.04004 @ 2008-04-15 11:39:32
  # DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:7O29VfwnVCsyZL2avThORA

主な変更点は、

DigestColumnsを使ってDigest認証用のハッシュ値を格納するようにした
TimeStampが勝手に挿入されるようにした

って感じ。

と言う訳で試してみる。

#!/usr/bin/perl

use strict;
use warnings;

use lib qw(lib);
use AuthSample::Schema;

my $schema = AuthSample::Schema->connect('dbi:SQLite:dbname=authsample.db');
$schema->resultset('User')->create({ user_id => 'zigorou', password => 'hogehoge' });

print $schema->find({ user_id => 'zigorou' })->password;

とすると、

c11485a6cebc09f30a61df78a33961df

などと出るので、どうやら問題なく動作している模様。念のためSQLiteコンソールでも確かめる。

sqlite> SELECT * FROM user;
1|zigorou|c11485a6cebc09f30a61df78a33961df|2008-04-15 02:59:12|2008-04-15 02:59:12

これでDBICはとりあえず出来た。

Catalyst側の実装とか設定とか

まずは最初にauthsample_server.plにモジュールのパスを追加しておきます。

use lib (
	"$FindBin::Bin/../lib",
	glob("$FindBin::Bin/../../*/lib")
);

こういう感じ。
今度はCatalyst側に移動して、./lib/AuthSample.pmの use Catalyst してる部分を次のように。

use Catalyst qw/
  -Debug 
  ConfigLoader 
  Static::Simple
  Cache
  Authentication
  Authentication::Store::DBIC
  Authentication::Credential::HTTP
/;

次にCatalyst::Model::AdaptorでDBIC::Schemaのadaptorを作ります。

$ ./script/authsample_create.pl model DBIC::Schema Adaptor AuthSample::Schema

出来上がったadaptorにprepare_arguments, mangle_argumentsを追加します。Catalyst::Utilsをuseしておく必要があります。
ついでにconfigのconstructorもnewからconnectに変更する。

__PACKAGE__->config( 
    class       => 'AuthSample::Schema',
    constructor => 'connect',
);

sub prepare_arguments {
    my ($self, $app) = @_;
    return $app->config->{Catalyst::Utils::class2classsuffix(__PACKAGE__)};
}

sub mangle_arguments {
    my ($self, $args) = @_;
    return $args ? @$args : ();
}

さらにAuthentication::Store::DBIC用にUserクラスを作ります。

$ ./script/authsample_create.pl model DBIC::Schema::User

生成されたModel::DBIC::Schema::UserにACCEPT_CONTEXT()を次のように追加する。

sub ACCEPT_CONTEXT {
    my ($self, $c, @args) = @_;

    return $c->model('DBIC::Schema')->resultset('User');
}

さらにyamlを次のように設定する。

------
Model::DBIC::Schema:
  - dbi:SQLite:dbname=/Users/zigorou/tmp/digestauth/AuthSample-Schema/authsample.db
authentication:
  dbic:
    password_field: password
    password_hash_type: MD5
    password_type: clear
    user_class: DBIC::Schema::User
    user_field: user_id
  http:
    algorithm: MD5
    type: digest
cache:
  backend:
	class: Cache::Memory
	default_expire: 600 sec
	namespace: test
name: AuthSample

これで準備完了です。

$ ./script/authsample_server.pl -d -r

とかで動くはず。

認証ページを作る

面倒なのでController/Root.pmに仕込みます。

sub default : Private {
    my ( $self, $c ) = @_;

    $c->authorization_required( realm => 'Are you TKSK?' );

    # Hello World
    $c->response->body( $c->welcome_message );
}

これで http://localhost:3000/ にアクセスすれば認証ページが出るはずです。
おしまい。

おまけ

今回作ったソース一式

2008-04-01

DBIx::Class::Service Released

Perl CPAN DBIC

~~まだCPANに反映されて居ないと思いますが、~~DBIx::Class:Serviceと言うモジュールをリリースしました。

どんなモジュールか

複数のテーブルにinsertしたりする処理をまとめて書く為のモジュールです。

具体的に言えば、

package MySchema::Service::User;

use base qw(DBIx::Class::Service);
  
sub add_user: Transaction {
  my ($class, $schema, $args) = @_;
  
  my $user_rs = $schema->resultset('User');
  
  my $user = $user_rs->create({
    user_seq => undef,
    user_id => $args->{user_id},
    password_digest => crypt($args->{password}, $args->{user_id}),
  });
    
  $user->create_related('profiles', {
    name => $args->{name},
    nickname => $args->{nickname},
  });
    
  return $user;
}

1;

みたいな感じで書けて、Schemaクラスにて、

package MySchema::Schema;
  
use base 'DBIx::Class::Schema';
  
__PACKAGE__->load_classes;
__PACKAGE__->load_components(qw/ServiceManager/);
__PACKAGE__->load_services({ 'MySchema::Service' => [qw/
  User
/] });

こんな風に書くと、

use MySchema::Schema;

my $schema = MySchema::Schema->connect($dsn, $dbuser, $dbpass);
eval {
  $schema->service('User')->add_user($args);
};
if ($@) {
  print STDERR $@;
}

みたいな感じで書けます。

なお、Transaction attributeを付けるとその部分はtxn_begin, txn_commitで囲われて、エラーが起きた場合はtxn_rollbackしてcroakするだけです。

と言う訳で

ご意見やバグレポートとかあればお知らせ下さい。~~CodeReposに移すかなー。~~移しました。

2008-03-28

GraphViz::ISA::MultiでDBICのクラスツリーを作る

Perl CPAN DBIC

~~もうすぐ送別会なのでソースだけ。~~
画像もうpりました。
とてもじゃないけど印刷出来ないグラフが表示されます。＞＜

ソース

#!/usr/bin/perl

use strict;
use warnings;

use Module::Find;
use GraphViz::ISA::Multi;

setmoduledirs("./lib");
my @modules = grep { $_ !~ /^DBIx::Class::(PK::Auto::|Storage::DBI::)/ } findallmod("DBIx");
my $gv = GraphViz::ISA::Multi->new();
$gv->add($_) for (@modules);
open(PNG, ">test.png");
print PNG $gv->as_png;
close(PNG);

イメージ

でかいです。

改訂版ソース

ソース読む前にドキュメント読むこと＞＜

#!/usr/bin/perl

use strict;
use warnings;

use Data::Dump qw(dump);
use Module::Find;
use GraphViz::ISA::Multi;

setmoduledirs("./lib");
my @modules = grep { $_ !~ /^DBIx::Class::(PK::Auto::|Storage::DBI::)/ } findallmod("DBIx");
my $gv = GraphViz::ISA::Multi->new();

$gv->add($_) for (@modules);

$gv->graph->{LAYOUT} = "fdp";

open(PNG, ">test.png");
print PNG $gv->as_png;
close(PNG);

改訂版画像

2008-03-24

DBIx::Class SourceCode Reading

Perl CPAN DBIC

を予備知識としてDBIx::Classを読み解きます。
もうなんか疲れて来た＞＜

mk_classdata(), mk_classaccessor()

sub mk_classdata { 
  shift->mk_classaccessor(@_);
}

sub mk_classaccessor {
  my $self = shift;
  $self->mk_group_accessors('inherited', $_[0]); 
  $self->set_inherited(@_) if @_ > 1;
}

ちなみにこれらは共にクラスメソッド、インスタンスメソッドのいずれでも呼び出し可能ではありますが、名前からしてクラスメソッドとして呼ぶべきでしょう。*1
まぁこれってClass::Data::Inheritableみたいな用途でmk_classdataを呼び出す事を想定しているんだけど、大きな違いはd:id:ZIGOROu:20080324:1206351293で説明したように、DBIx::ClassはMROがC3ですから、探索順がdepth-firstではありません。*2

C3な探索順で継承可能なクラス変数的な値を宣言するのに使ってるみたいですね。

component_base_class()

これは意図的に呼ぶ物ではなくてClass::C3::Componentised用にあるメソッド。*3

sub component_base_class { 'DBIx::Class' }

load_component()を呼び出した時にsuffixとしてこのメソッドの戻り値が採用されます。

MODIFY_CODE_ATTRIBUTES(), _attr_cache()

sub MODIFY_CODE_ATTRIBUTES {
  my ($class,$code,@attrs) = @_;
  $class->mk_classdata('__attr_cache' => {})
    unless $class->can('__attr_cache');
  $class->__attr_cache->{$code} = [@attrs];
  return ();
}

sub _attr_cache {
  my $self = shift;
  my $cache = $self->can('__attr_cache') ? $self->__attr_cache : {};
  my $rest = eval { $self->next::method };
  return $@ ? $cache : { %$cache, %$rest };
}

これはCatalystな人にはおなじみのコードですね。
前者はメソッドにつけたattributeをそのメソッドのCODEREFをキーにしてARRAYREFとして__attr_cacheに保存しておきます。

後者は_attr_cacheが継承ツリーで存在する限りnextでグルグル叩きまくって全てのCODE対attrのHASHREFを取って来ます。

#!/usr/bin/perl;

package Foo;

use base qw(DBIx::Class);
use Class::C3;

sub foo: Hoge Fuga { __PACKAGE__ }

package main;

use Data::Dump qw(dump);
print dump(Foo->_attr_cache);

は例えば、

{ "CODE(0x1808b08)" => ["Hoge", "Fuga"] }

感じになります。

まとめ

DBIx::Classを継承すると以下のような事が出来るようになります。

Class::C3::Componentised由来のload_*_components()による継承ツリーへの動的inject
- load_componentsはDBIx::Class::*なモジュールをprefixを略してinject
- load_own_componentsは今のpackage名をprefixにしたモジュールをprefixを略してinject
- load_optional_componentsはload_componentsと大体同じ。存在確認付きなので無ければ読まない。
メソッドに付けたattributesを_attr_cacheに保存します。
- 取り出す際はキーがCODEREFなのでClass::Inspector/シンボルテーブルとかでゴニョらないとダメだと思う
Class::Accessor::Groupedのメソッドが全て使えます
- 必要ならばmk_group_accessors()にて自前のアクセサをバックエンドのオブジェクトを隠蔽して定義出来る
継承可能なクラス変数的な物はmk_classdata()を使う
- __PACKAGE__->mk_classdata("foo" => { id => 1, name => "zigorou" }) とかとか

概ねこんなのがDBIx::Classのベースになってるみたいです。

*1:実際そう呼んでます

*2:http://d.hatena.ne.jp/amachang/20061007/1160232763 が分かりやすいです

*3:http://d.hatena.ne.jp/ZIGOROu/20080317/1205779889

2008-03-24

Class::Accessor::Grouped

Perl CPAN

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と言う所以かな、多分

2008-03-24

DBIx::Class::Componentised Source Code Reading

Perl CPAN DBIC

d:id:ZIGOROu:20080317:1205779889 の続きです。

DBIx::Class::Componentisedとは

恐らくDBIC関連のdistにおける基底クラスだと考えて良いと思います。
DBIx::Classはこのクラスを継承していて、DBIx::Class::Componentisedは前回説明した、Class::C3::Componentisedを継承しています。

inject_base()

Class::C3::Componentisedでは、

特定のクラスに対して複数のコンポーネントをinjectする。一回reverseしてからその特定のクラスがコンポーネントを継承していないならば、継承順位で先頭にどんどん突っ込んで行く。

と言う処理でした。
このinject_baseはload_*_components()で呼び出されるメソッドです。

DBIx::Class::Componentisedは同名のメソッドを定義して*1いて、

sub inject_base {
  my ($class, $target, @to_inject) = @_;
  {
    no strict 'refs';
    foreach my $to (reverse @to_inject) {
      my @comps = qw(DigestColumns ResultSetManager Ordered UTF8Columns);
           # Add components here that need to be loaded before Core
      foreach my $first_comp (@comps) {
        if ($to eq 'DBIx::Class::Core' &&
            $target->isa("DBIx::Class::${first_comp}")) {
          warn "Possible incorrect order of components in ".
               "${target}::load_components($first_comp) call: Core loaded ".
               "before $first_comp. See the documentation for ".
               "DBIx::Class::$first_comp for more information";
        }
      }
      unshift( @{"${target}::ISA"}, $to )
        unless ($target eq $to || $target->isa($to));
    }
  }

  $class->next::method($target, @to_inject);
}

となってよりDBICのcomponentに対して具体的なコードになっていて、

DBIx::Class::Coreがloadされるよりも前に他のcomponentがloadないしは継承されていた場合は警告を出す
targetに対して@ISAにinjectしたいclassをunshiftしていく

となっていて、Class::C3::Componentisedと大体同じ事をやっている。(2番目のは全く同じ)
当然、このクラス内で@to_injectにあったクラスは全てtargetの@ISAに収まるからnextで呼び出されたClass::C3::Componentisedは結果的に何もしなくなる。

前者の方はqw(DigestColumns ResultSetManager Ordered UTF8Columns)とCoreの関係を追えば何故こういう処理をしているか自ずと明らかになりそうなのでスルー。

load_optional_class()

Class::C3::Componentisedのload_optional_components()から呼ばれているcomponentのフィルタ条件がこのメソッド。

sub load_optional_class {
  my ($class, $f_class) = @_;
  if ($class->ensure_class_found($f_class)) {
    $class->ensure_class_loaded($f_class);
    return 1;
  } else {
    return 0;
  }
}

クラスが見つかって
ロードされてれば

真を返すのでただの存在確認。ensure_class_*()はClass::C3::Componentisedのメソッド。

まとめ

DBIx::Class::Componentisedは別段特別な事をやってる訳じゃない

まぁClass::C3::Componentisedとほとんど変わらないって事で良さそう。

*1:overrideとはC3の場合は言わない？

日向夏特殊応援部隊

俺様向けメモ

XRI::Resolution::Liteのサンプル

Catalyst/DBICでDigest認証する

準備

まずはCatalystプロジェクトを作ります

ユーザー用のDBIC スキーマを定義します。

DBIC関連を今回は手動でちょっと弄る

Catalyst側の実装とか設定とか

認証ページを作る

おまけ

DBIx::Class::Service Released

どんなモジュールか

と言う訳で

GraphViz::ISA::MultiでDBICのクラスツリーを作る

ソース

イメージ

改訂版ソース

改訂版画像

DBIx::Class SourceCode Reading

mk_classdata(), mk_classaccessor()

component_base_class()

MODIFY_CODE_ATTRIBUTES(), _attr_cache()

まとめ

Class::Accessor::Grouped

要約

使い方

詳しく説明

mk_group_accessors($group, @fields)

make_group_accessor($group, $field)

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

DBIx::Class::Componentised Source Code Reading

DBIx::Class::Componentisedとは

inject_base()

load_optional_class()

まとめ

準備

まずはCatalystプロジェクトを作ります

ユーザー用のDBICスキーマを定義します。

DBIC関連を今回は手動でちょっと弄る

Catalyst側の実装とか設定とか

認証ページを作る

おまけ

どんなモジュールか

と言う訳で

ソース

イメージ

改訂版ソース

改訂版画像

mk_classdata(), mk_classaccessor()

component_base_class()

MODIFY_CODE_ATTRIBUTES(), _attr_cache()

まとめ

要約

使い方

詳しく説明

mk_group_accessors($group, @fields)

make_group_accessor($group, $field)

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

DBIx::Class::Componentisedとは

inject_base()

load_optional_class()

まとめ

ユーザー用のDBIC スキーマを定義します。