Hatena::ブログ(Diary)

Yet Another Hackadelic

2008-04-23 IT幹事疲れ

DBIC::Schema::Loaderのカスタマイズと言うネタでプレゼンするはずだった件

話してないけど、資料はあるので公開しまっする。

概要

開発中にスキーマに変更が発生して、make_schema_at()を何度も叩く際に困ることと、Schema::Loaderで比較的意図した通りにSchema, Tableクラスを生成する為に、こんな風にするといいおって内容です。

せっかちな人向け

こんな感じ。

内容の解説はプレゼン資料を見てくだしあ。

#!/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 unless @ARGV;

my $schema_class = 'MyClass::DBIC::Schema';

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

use DBIx::Class::Schema::Loader::Base;
package DBIx::Class::Schema::Loader::Base;

use String::CamelCase qw(decamelize);

{
    no warnings 'redefine';

    sub _load_relationships {
        my ( $self, $table ) = @_;

        my $tbl_fk_info = $self->_table_fk_info($table);
        foreach my $fkdef (@$tbl_fk_info) {
            $fkdef->{remote_source}
                = $self->monikers->{ delete $fkdef->{remote_table} };
        }

        my $local_moniker = $self->monikers->{$table};
        my $rel_stmts     = $self->{relbuilder}
            ->generate_code( $local_moniker, $tbl_fk_info );

        foreach my $src_class ( sort keys %$rel_stmts ) {
            my $src_stmts = $rel_stmts->{$src_class};
            foreach my $stmt (@$src_stmts) {
                if ($stmt->{method} eq 'belongs_to') {
                    my $table_class_suffix = [split /::/ => $stmt->{args}->[1]]->[-1];
                    $stmt->{args}->[0] = decamelize($table_class_suffix);
                }

                $self->_dbic_stmt( $src_class, $stmt->{method},
                    @{ $stmt->{args} } );
            }
        }
    }
}

package main;

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

まぁ、俺様Loader作るないしはDBICを使わないのがベストプラクティスな気がします。(冗談だけど)

SEE ALSO

2008-04-15 選択次第

Catalyst/DBICでDigest認証する

自分の為のメモですよ。

準備

まずは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,
);

こんな感じ。改良点は、

  1. 各テーブルクラスは自分で自ら消す
  2. 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

主な変更点は、

  1. DigestColumnsを使ってDigest認証用のハッシュ値を格納するようにした
  2. 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 甘んじてDISられる所存です

DBIx::Class::Service Released

まだ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のクラスツリーを作る

もうすぐ送別会なのでソースだけ。

画像もう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);

イメージ

でかいです。

f:id:ZIGOROu:20080401123630p:image

改訂版ソース

ソース読む前にドキュメント読むこと><

#!/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);

改訂版画像

f:id:ZIGOROu:20080401125701p:image

2008-03-24 唯己のみを是とする

DBIx::Class SourceCode Reading

を予備知識として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のベースになってるみたいです。

DBIx::Class::Componentised Source Code Reading

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してからその特定のクラスがコンポーネントを継承していないならば、継承順位で先頭にどんどん突っ込んで行く。 Class::C3::Componentised Source Code Reading

と言う処理でした。

このinject_baseはload_*_components()で呼び出されるメソッドです。

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

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したいclassunshiftしていく

となっていて、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:実際そう呼んでます

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

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

*4:overrideとはC3の場合は言わない?