チェックデジットとは

さて、「CheckDegit(チェックデジット)」という言葉に馴染みのない方もいらっしゃると思うので、まずは基本的なお話から。

Wikipediaによると、

「チェックディジット（check digit, 検査数字）とは、
符号の入力誤りなどを検出するために元の符号に付加される数字のこと。」

とされています。

馴染みの深いところでは、バーコードなどで読み取りミスを防ぐために、最後の一桁にチェックデジットを付与して、データを誤って読み取ってしまうことを防いでいます。

例えば、「初めてのPerl」のISBN"978-4-87311-126-1"の最後の"1"はチェックデジットです。

計算してみる

まずは実際に上のISBNコードのチェックデジットを計算してみます。

ISBNコードやJANコードは、「モジュラス10 ウェイト3・1」というアルゴリズムで算出されます。

このアルゴリズムでは、"左から奇数桁の数字の合計"と、"偶数桁の数字の合計を3倍にしたもの"を加え、10からその和の下一桁の数字を引いてチェックデジットを求めます。

(9 + 8 + 8 + 3 + 1 + 2) + (7 + 4 + 7 + 1 + 1 + 6) * 3 = 109 ・・・下一桁は9
10 - 9 = 1 ・・・ この1がチェックデジット

確かに計算結果と実際の値とが一致しました。比較的簡単な計算のアルゴリズムですね。

Perl登場｜・ω・)ノ

Perlの苦手な方はチェックデジットくらい暗算をするみたいですが、

小学校を卒業した賢いCasual Perlerの皆さんは当然Perlを使いますよね。

というわけで、Perlで簡単にチェックデジットを付与し、あるいは検証するモジュールの紹介です。

Algorithm::CheckDegits

use Algorithm::CheckDigits;

my $isbn13 = CheckDigits('ISBN13');
if ($isbn13->is_valid('978-4-87311-126-1')) {
    # OK
}

my $lp_isbn = $isbn13->complete('978-4-87311-126');
print $lp_isbn . "\n";

上の通り、CheckDigits()関数にて付与したいチェックデジットの種類を指定します。

ここでは、13桁の新ISBNコードを使っていますので、"ISBN13"という指定をしています。

他には、クレジットカードの"VISA"や"AMEX"、"DINERS"、Amazon等でおなじみの"EAN"(JANもこれと同じ)などが指定できます。

指定できるアルゴリズム名の一覧は、

my @ml = Algorithm::CheckDigits->method_list();

で取得できます。

ちなみに、m10_005などという命名がなされていますが、それは必ずしも名前通りモジュラス10ウェイト5という意味ではないようですので注意が必要です。

※実際にはm10_004がモジュラス10ウェイト3.1に該当、m10-005がモジュラス10ウェイト4.9に該当など

実際のアルゴリズムを確認したい場合は、以下のようにperldocを参照するか、ソースをご覧ください。

perldoc Algorithm::CheckDigits::M10_005

様々な用途

チェックデジットというのは、数値の検証に用いるのが本来の用途だと思いますが、それ以外にも私自身は以下のような用途で使っています。

• IDの桁数を揃えたい場合で、桁数に余裕があり、かつ連番やゼロを避けたいとき(00001,00002,00003...よりも00016,00025,00034...とすることで連番を避けた様に見える)
• JANコードやISBN等を保存する際、1文字分の容量を節約したいとき
• 彼女の誕生日の下一桁を忘れたとき

クリスマスチェックデジット

チェックデジットでクリスマスがcompleteできるか遊んでみました。

my $christmas = CheckDigits('EAN');
print $christmas->complete('2009122'); # 結果はご自身でご確認ください:)

最後に

さて、25日間にわたってお楽しみいただいたJperl Advent Calendar - Casual Trackも今日で最後となりました。

毎日欠かさずチェックいただいたcasual perlerやperl hackerの皆さんありがとうございました。

そして、今日まで途切れることなくバトンをつないで頂いたcasual perlerの皆様お疲れ様でした。

また来年のAdvent Calendarに参加できることを楽しみにしています。

それでは、皆様良いお年を。

参考

• http://search.cpan.org/~mamawe/Algorithm-CheckDigits-0.53/
• http://ja.wikipedia.org/wiki/%E3%83%81%E3%82%A7%E3%83%83%E3%82%AF%E3%83%87%E3%82%A3%E3%82%B8%E3%83%83%E3%83%88
• http://ja.wikipedia.org/wiki/JAN%E3%82%B3%E3%83%BC%E3%83%89

Special Thanks

id:kimury

今後の Data::Model

今後の予定ですが、夏に sfujiwara さんからいただいた Pg 対応の取り込みやら、 リレーショナルスキーマのサポートやら細かい fix 項目など TODO はまだまだあります。

Data::Model はリレーショナルしないっていってたじゃん！ってツッコミもありますが、いい実装方法を思いついたのでやってみようと思います。

もし今回の企画で Data::Model に興味をもって使ってみようと思っていただけたら嬉しいです。

不明点やらなんやらがあれば #perl-casual@freenode やら #data-model@irc.perl.org やら #dbix-skinny@irc.perl.org やら適当なところで捕まえてくれればとおもいます。

ではでは、本当に僕の advent calendar 2009 はこれにておわりです。

水着もってバカンスいってきます。

まえおき

みなさんがコードを書く上で依存モジュールの管理に悩む。なんてのは誰しもが通る道だと思います。

もうすでに Makefile.PL の中に依存モジュールを書けば、依存モジュールを全部入れてくれるので悩む事は無いと思います。

さらには、テストケースで必要な依存モジュールのチェックなども Test::Requires が登場した事により、気楽にテストする事も出来ます。

だがしかし、プラガブルなモジュールなどが含まれるディストリビューションを作ったときに、このサブモジュールを使う時は、このモジュールも入れてね的に Makefile.PL に以下のような feature 句を入れるかと思います。

# Plack の Makefile.PL から拝借
feature 'FastCGI daemon and dispatcher',
    -default => 0,
    'FCGI' => 0.67,
    'FCGI::Client' => 0.02;

これは、実際のインストールフェーズでは以下のように依存モジュールを入れるか聞かれます。

[FastCGI daemon and dispatcher]
- FCGI                            ...missing.
- FCGI::Client                    ...missing.
==> Auto-install the 2 optional module(s) from CPAN? [n] 

ユーザがインストールする時に、ここで提示されたモジュールを入れてくれれば何も問題ないでしょう。

しかしながら、最初は要らないと思っていても後で使う気になった時には当然これら必須モジュールがはいっていないので「Can't Locate ...」などのエラーが出てきます。

不足してる依存モジュールが少数だったら許せるでしょうが、足りないモジュールがいっぱいあると「Can't Locate ...」と言われるたびに install するとかいうめんどくさい事になってしまいます。

簡単に言うと Module::Requires は、この「Can't Locate ...」エラーメッセージを一度に出して依存モジュールで足りてないモジュール群を一度に提示してあげるという事に使えるのです。

# もちろん、これを排除するには sub feature 的なモジュールを別ディストリにしちゃうのが一番綺麗でしょう

簡単な使い方

使い方はとても簡単です。

例えば Class::Trigger と Class::Accessor に依存してる場合には以下のように書きます。

use strict;
use warnings;
use Module::Requires 'Class::Trigger', 'Class::Accessor';
use Class::Trigger;
use Class::Accessor;

もし、両方ともインストールされてないときは下記のようなエラーメッセージを出力します。

Can't load Class::Trigger
Can't locate Class/Trigger.pm in @INC (@INC contains: ry) at (eval 1) line 2.
BEGIN failed--compilation aborted at (eval 1) line 2.

Can't load Class::Accessor
Can't locate Class/Accessor.pm in @INC (@INC contains: ry) at (eval 2) line 2.
BEGIN failed--compilation aborted at (eval 2) line 2.
 at lib/Module/Requires.pm line 105
        Module::Requires::import('Module::Requires', 'Class::Trigger', 'Class::Accessor') called at ./a.pl line 3
        main::BEGIN() called at lib/Module/Requires.pm line 3
        eval {...} called at lib/Module/Requires.pm line 3
BEGIN failed--compilation aborted at ./a.pl line 3.

ちゃんと、両方の「Can't Locate ...」エラーメッセージが同時に出てきます。

もちろん片方がインストールされてれば、片方だけのエラーメッセージを出すし10個くらいのモジュールをチェックしてて全部入ってなければ全部のエラーを出します。

バージョンの指定

もちろん通常の use と同じようにバージョンの指定もできます。

use strict;use warnings;
use Module::Requires
    'Class::Trigger'  => 0.99,
    'Class::Accessor' => 14.22;
use Class::Trigger;
use Class::Accessor;

こう書くと以下のようにバージョンがたりねー！と怒ります。

Class::Trigger version 0.99 required--this is only version 0.13
Class::Accessor version 14.22 required--this is only version 0.31 at lib/Module/Requires.pm line 105
        Module::Requires::import('Module::Requires', 'Class::Trigger', 0.99, 'Class::Accessor', 14.22) called at ./a.pl line 4
        main::BEGIN() called at lib/Module/Requires.pm line 5
        eval {...} called at lib/Module/Requires.pm line 5
BEGIN failed--compilation aborted at ./a.pl line 5.

細かいバージョンの指定

例えば、とあるモジュールが 0.10 まで出ていて 0.03 以上が入ってたら良いんだけど、 0.09 だけバグがあるので 0.03 以上で 0.09 以外のモジュールに依存したいとか書く必要が出てくる場合があると思います。

記憶が確かなら他の CPAN モジュールでも上記要求を満たすモジュールが入ってれば load するなんてのもありますが、 Module::Requires の機能としても実装してあります。

use strict;
use warnings;
use Module::Requires
    'Foo'  => [ '>' => 0.03, '!=' => 0.09 ],
    'Bar'  => [ '<=' => 0.02, '>=' => 0.01 ],
    'Baz'  => [ '<' => 0.08 ];
use Foo;

もしもインストールされている Foo のバージョンがが 0.09 であった場合下記のエラーを吐きます。

Foo version > 0.03 AND != 0.09 required--this is only version 0.09 at /lib/Module/Requires.pm line 105
        Module::Requires::import('Module::Requires', 'Foo', 'ARRAY(0x81948c)') called at ./a.pl line 4
        main::BEGIN() called at lib/Module/Requires.pm line 4
        eval {...} called at lib/Module/Requires.pm line 4
BEGIN failed--compilation aborted at ./a.pl line 4.

同時にロードする

実は上の方法では、 Module::Requires::* 以下の名前空間から各種モジュールを require してるだけなので use Module::Requires してる名前空間から正しく use するには別途 use ModuleName として書かないと正しく use 出来ませんでした。

これでは冗長なケースもあるので -autoload というオプションを付ける事により require チェックと同時に require && module->import を行うようになります。

# これは encode_base64 が入ってないのでだめよ
use strict;
use warnings;
use Module::Requires
    'MIME::Base64';
print encode_base64('last day');

# 正しく encode_base64 が load されてる
use strict;
use warnings;
use Module::Requires -autoload,
    'MIME::Base64';
print encode_base64('last day');
# use MIME::Base64; と同等

# decode_base64 しか export されてないので動かない
use strict;
use warnings;
use Module::Requires -autoload,
    'MIME::Base64' => {
        import => ['decode_base64'],
    };
print encode_base64('last day');
# use MIME::Base64 'decode_base64'; と同等

# これは encode_base64 だけを export してるので動く
use strict;
use warnings;
use Module::Requires -autoload,
    'MIME::Base64' => {
        import => ['encode_base64'],
    };
print encode_base64('last day');
# use MIME::Base64 'encode_base64'; と同等

このようにして、import メソッドに渡す引数を指定します。

use ModuleName () と同等にするには下記のように書きます。

# decode_base64 しか export されてないので動かない
use strict;
use warnings;
use Module::Requires -autoload,
    'MIME::Base64' => {
        import => [],
    };
print encode_base64('last day');
# use MIME::Base64 (); と同等

use Module () って空括弧を引数に渡すと import を呼ばなくなる仕様を忘れててすっかりドハマリしてバグ作ってましたが直しました＞＜

autoload しつつ version していする

これも出来ます。

use Module::Requires -autoload,
    'MIME::Base64' => {
        import  => [qw/ encode_base64 /],
        version => 0.03,
    };
# use MIME::Base 0.03 qw( encode_base64 ); と同等

こんな風にシンプルなバージョンの指定から

use Module::Requires -autoload,
    'MIME::Base64' => {
        import  => [qw/ encode_base64 /],
        version => [ '>=' => 0.03, '!=' => '0.08' ],
    };

のような細かいバージョンの制御もできます。

まとめ

Module::Requires を使ってモジュールの依存を細かく定義して、万が一依存モジュールの条件を満たさない場合はユーザが楽できる用にエラーを出すという事を紹介しました。

バグ出しやらなんやらで賞味一時間強で創り上げました。

また、このモジュールの実際の仕様のネタ出しは lestrrat さんと nekokak さんにして頂きましたありがとうございます。

例によって英語ドキュメントが不足気味なので、興味を持たれた方は是非ともドキュメントを充実させてくれると嬉しいです。

ということで地味なモジュールで今年の JPerl Advent Calendar を締めくくりましたが、そんなんで良いんじゃないかとおもいます。

ではでは、関係者の皆さんお疲れ様でした。こんどは寿司屋でありましょう！

はじめに

まずはImage::Imlib2をインストールしましょう。

インストールをする前に、Cのライブラリと使いたい画像形式のライブラリを入れておきましょう。

今回はjpegとpngを使いたいと思います。

$ port install libpng
$ port install imlib2

ではImage::Imlib2をインストールします。簡単ですね！

cpan> install Image::Imlib2

画像の読み込み、書き出し

インストールできたら、画像を読み込んだり書き出したりしてみましょう。

face.jpgを読み込んで、face2.jpgに書き出してみます。

#!/usr/bin/perl

use strict;
use warnings;
use Image::Imlib2;

my $dir = '/path/to/image';

my $image = Image::Imlib2->load("$dir/face.jpg");
$image->save("$dir/face2.jpg");

できた画像

画像の合成

これであなたもImage::Imlib2を使うことができました！が、肝心のアイコンがさみしいです＞＜

クリスマスということで、サンタ帽をかぶってみましょう。

このようなサンタ帽画像を用意します。それでは合成してみましょう。

#!/usr/bin/perl

use strict;
use warnings;
use Image::Imlib2;

my $dir = '/path/to/image';

my $image = Image::Imlib2->load("$dir/face.jpg");
$image->set_quality(100);
my $santa_hat = Image::Imlib2->load("$dir/santa_hat.png");
$image->blend($santa_hat, 1, 0, 0, 300, 300, 0, 0, 300, 300);

$image->save("$dir/with_santa_hat.png");

できた画像

サンタ帽をかぶることができました！簡単ですね！

画像を作成する

サンタ帽をかぶってクリスマスっぽくなりました。もうひといき、今度は星画像を作ってみましょう。

Image::Imlib2::Polygonというモジュールを使って多角形を作ります。

星形は正五角形の頂点を結ぶので、先にShape::RegularPolygonを利用して正五角形の頂点を取得しておきます。

そのあと1つ飛びに頂点を描き、まさに手書きで星を書くときのように描いていきます。

これだけでは中の正五角形が塗られないので、中身も後から塗って星形の完成です。

#!/usr/bin/perl

use strict;
use warnings;
use Data::Dumper;
use Image::Imlib2;
use Shape::RegularPolygon;

my $dir = '/path/to/image';

my $image = Image::Imlib2->new_transparent(100, 100);
$image->set_colour(255, 255, 0, 255);

my $points = &get_points(50);
my $poly = Image::Imlib2::Polygon->new();

for my $point (@$points) {
    $poly->add_point($point->{x}, $point->{y});
}
$poly->fill();

$image->draw_polygon($poly, 1); 
$image->fill(50,50);
$image->save("$dir/star.png");


sub get_points {
    my $center = shift;

    my $polygon = new Shape::RegularPolygon;
    $polygon->center($center, $center);
    $polygon->sides(5);
    $polygon->radius(50);
    my @points = $polygon->points;

    return [$points[0], $points[2], $points[4], $points[1], $points[3], $points[0]];
}

できた画像

できた画像を合成します。

create_rotate_imageで画像を回転させて貼り付けます。

#!/usr/bin/perl

use strict;
use warnings;
use Image::Imlib2;

my $dir = '/path/to/image';

my $image = Image::Imlib2->load("$dir/with_santa_hat.png");
$image->set_quality(100);
my $star = Image::Imlib2->load("$dir/star.png");
$image->blend($star, 1, 0, 0, 100, 100, 0, 200, 100, 100);

my $rotated = $star->create_rotated_image(30 / 360 * 3.141519*2);
$image->blend($rotated, 1, 0, 0, 150, 150, 210, 80, 100, 100);

$image->save("$dir/with_star.png");

できた画像

できました！これでアイコンがにぎやかになりましたね！

まとめ

Image::Imlib2を使うと簡単に画像を加工することができます。ちょっとした画像編集にPerlを使ってみるのはいかがですか？

明日はAdvent Calendarの大トリ、piarraさんです。楽しみですね！

参考

• http://search.cpan.org/~lbrocard/Image-Imlib2-2.03/lib/Image/Imlib2.pm
• http://yusukebe.com/tech/archives/20070526/011710.html
• http://it.kndb.jp/entry/show/id/2572
• http://rakasaka.fc2web.com/delphi/star.html

Driver を作るために必要な知識

Driver を作るためにはある程度規則に従う必要があります。

ゼロから独自の Driver を作るには Data::Model::Driver の中で空定義してあるメソッドを上書きする必要があります。

そして Data::Model::Driver の各メソッドは Data::Model より delegation されているので、 Data::Model のコードも読んでおく必要があります。

このあたりはドキュメントされていません。

また、内部 API が変わってしまうと互換性が無くなる可能性もあり厄介です。

ということで本日は、需要がありそうで簡単そうな Driver を作る方法を軽く紹介します。

Driver::DBI を拡張する

主に一昨日紹介した Driver::DBI::MasterSlave の挙動が気にくわないと言った事で作りたい欲求が出るでしょう。

Driver::DBI::MasterSlave は Driver::DBI の dbh のやりくりを制御する部分を独自にハンドリングして master, slave の dbh を切り替えるという要求にしたがって作られています。

rw_handle, r_handle が返す値をうまい具合にやりくりすれば、独自のレプリケーション対応の Driver がかけます。

Driver::DBI::MasterSlave のコードを元にして、どのあたりをいじれば良いのかを紹介しましょう。

継承するクラス

なので、しちめんどい set,get,update,delte,lookup などの処理は再実装しないで Driver::DBI にやってもらえばいいので、これを継承します。

package Data::Model::Driver::DBI::MasterSlave;
use strict;
use warnings;
use base 'Data::Model::Driver::DBI';

クラス初期化

Data::Model::Driver の初期化は new メソッドの引数を全て bless { %args }, $class のようにして保存してから、 init メソッドを単純に呼び出しています。

なので、独自 Driver の初期化処理は init メソッドの中で行います。

sub init {
    my $self = shift;
    my $master = $self->{master}
        or Carp::croak "'master' configuration is required";
    my $slave  = $self->{slave} || $master;

    if (my($type) = $master->{dsn} =~ /^dbi:(\w*)/i) {
        $self->{dbd} = Data::Model::Driver::DBI::DBD->new($type);
    }
    $self->{dbi_config} = +{
        master => +{ %{ $master } },
        slave  => +{ %{ $slave } },
    };
}

今回は rw_handle, r_handle を自由に差し替えたいという要求を設定しました。

Driver::DBI のでは、このあたりも自由に差し替えするコードを書きやすくしてあります。

状況に応じた DBI のインスタンスを複数作れる用になっており、複数のインスタンスを作るためには DBI の設定を複数設定しておく準備が必要です。

具体的には $self->{dbi_config} に config_name => $config という形で HASH リファレンスを指定します。

Driver::DBI::MasterSlave では master と slave という設定名を使って、二つの設定を保存しています。

$self->{dbd} に Data::Model::Driver::DBI::DBD のインスタンスを入れているところは Driver::DBI で各種 DBD に対応した SQL を吐くために必須ですので注意してください。

dbh を使い分ける

さぁ DBI インスタンスの設定を複数作ったら、あとはそれぞれ使うだけです。

これはrw_handle と r_handle のメソッドをそれぞれ上書きします。

sub rw_handle { shift->_get_dbh('master', @_) };
# トランザクション中は master のみを返す
sub r_handle  { my $self = shift;$self->_get_dbh( ($self->{active_transaction} ? 'master' : 'slave'), @_ ) };

見れば分かりますが $self->_get_dbh(config_name) といった形で _get_dbh のプライベートメソッドを読んでいます。

通常は、このように $self->{dbi_config} に格納した設定名を引数にして呼び出せば、その設定を引数にして自動的に DBI インスタンスを作ってくれるので、それを戻すだけでやりたい事が出来ます。

r_handle では $self->{active_transaction} が真だったら master を見るようにしていますが、これは txn_scope 下では常に master を見るべきという設計によるものです。

今の Data::Model の Driver::DBI では、このあたりもハンドリングしてあげる必要があります。

応用

例えば複数台の slave の設定を設定してランダムにその slave を使いたい場合は下記の用な Driver を書きます。

package Data::Model::Driver::DBI::ManySlave;
use strict;
use warnings;
use base 'Data::Model::Driver::DBI::MasterSlave';

sub init {
    my $self = shift;
    my $master = $self->{master}
        or Carp::croak "'master' configuration is required";
    my $slave  = $self->{slave} ? ref($self->{slave}) eq 'ARRAY'
        ? $self->{slave} : [ $self->{slave} ] : [ $master ];
    $self->SUPER::init(
        master => $master,
        slave  => $slave,
    );
}

slave のオプションを ARRAY ref にする感じです。

殆ど Driver::DBI::MasterSlave の実装を使いまわすので、ここは Data::Model::Driver::DBI::MasterSlave をそのまま継承します。

次は rw_handle と r_handle かと思いますが、 Driver::DBI::MasterSlave の物をそのまま使います。

では、 slave の r_handle を複数から選択するのは選択するの?という疑問ですが、新しく紹介するメソッドを上書きして使います。

dbi_config というメソッドを上書きします。

$self->{dbi_config} に DBI への設定を入れていたと思いますが、この設定を取り出すためのメソッドとして定義されています。

sub dbi_config {
    my($self, $name) = @_;
    return $self->{dbi_config}->{master} if $name eq 'master';
    my $slave = $self->{dbi_config}->{slave};
    return $slave->[rand(@{ $slave })];
}

このようにして master の時は $self->{dbi_config}->{master} を返して、 slave の時は slave の設定をどれかランダムで返すのです。

DBI のインスタンスを作る為のメソッドの中では dbi_config を使って DBI の設定を取得しているので、ここだけを変更すればうまく行きます。

使ってみる

さて、この作った Driver::DBI::ManySlave を使ってみますか。

my $many = Data::Model::Driver::DBI::ManySlave->new(
    master => {
        dsn => 'dbi:mysql:host=master.server:database=test',
    },
    slave => [
        { dsn => 'dbi:mysql:host=slave1.server:database=test' },
        { dsn => 'dbi:mysql:host=slave2.server:database=test' },
        { dsn => 'dbi:mysql:host=slave3.server:database=test' },
        { dsn => 'dbi:mysql:host=slave4.server:database=test' },
    ],
);

これだけです。

とりとめのない話

これだけの為にわざわざコード書くのはちょっと面倒なので Driver::DBI の設定だけでうまく行くようにしようと思います。

現状でも微妙に出来そうなコード片が入ってるのですが、完璧じゃないのでもすこし書き直してから公開しようとおもいます。

Driver::Cache を拡張する

さて、次は透過的なキャッシュをする Driver を独自の物に書いてみましょう。

標準では Perl 固有の HASH の中にキャッシュするか、 Memcached なオブジェクトへのキャッシュしか選択出来ません。

しかし Driver::DBI と比べてもさらにシンプルなんです。

基本的な Driver としての実装は Data::Model::Driver::Cache の中で実装されており、これを継承して Driver::Cache 用のインターフェイスを満たせば OK なんです。

これも既存の Driver::Cache::HASH のコードを元に説明しましょう。

データ追加

データの追加するメソッドを定義します。

sub add_to_cache {
    my($self, $key, $data) = @_;

    my $ret = $CACHE{$key} = $data;
    return if !defined $ret;
    return $ret;
}

add_to_cache の第一引数に key を、第二引数に value が渡されます。

成功したら value をそのまま返してください。

失敗時は undef を返します。

データ取得

データを取得する処理で使われます

sub get_from_cache {
    my($self, $key) = @_;

    my $ret = $CACHE{$key};
    return if !defined $ret;
    return $ret;
}

get_to_cache の第一引数に key が渡されます。

成功したら key に対応する value をそのまま返してください。

失敗時は undef を返します。

データ削除

データを削除する処理で使われます

sub remove_from_cache {
    my($self, $key) = @_;
    
    my $ret = delete $CACHE{$key};
    return if !defined $ret;
    return $ret;
}

remove_from_cache の第一引数に key が渡されます。

失敗したら undef を返してください。

成功したら undef 以外を返してください。

今現在 0 や '' などを返しても失敗したと誤認識するバグが発見されました。

その他

update 処理は、該当する key の削除のみを行うという挙動になっています。

トランザクションとの組み合わせは、現在完全な透過処理が行われません。

lookup_multi 系のクエリは get_multi_from_cache を上書きします。

以下に Memcached で利用してるコードを張り付けます。

sub get_multi_from_cache {
    my($self, $keys) = @_;

    my $ret = $self->{memcached}->get_multi($keys);
    return if !defined $ret;
    return $ret;
}

まったく新規に Driver を作る

もうちょっと詳細に書く予定でしたが、基本的に本日紹介した方法を見れば大体の Driver 作成の要求を満たせるかなと思ったので今回は省略させてください。

もし、そのような需要がある場合は Yappo を捕まえて相談してみてください。

他の DBD 対応

Driver とは直接関係ないですが mysql や SQLite 以外の DBD 対応へのポインタを示します。

Data::Model::Driver::DBI::DBD 以下の名前空間の実装を見てください。

基本的に SQL generator からの delegation されるコードですので delegation 元の Data::Model::Schema::SQL などを読んでみてください。

DBD::Pg に関しては sfujiwara さんが実装してくださったので僕の merge まちです＞＜

まとめ

本日は Driver hack についてあれこれ書きました。

さぁ、明日はいよいよ最終回です。

まえおき

というわけで、Perlで機械語を埋め込む技を応用すると、ActivePerl で stdcall な通常のDLL関数だけでなく、MSVCRT.DLL に含まれる sprintf のような可変長引数の cdecl な呼び出し規約の関数も利用できます。

#!/c/perl/bin/perl
use strict;
use warnings;
use Win32::API;

#include 
my $EnumWindows = Win32::API->new( "user32", "EnumWindows", "NN", "N" );
my $GetProcAddress = Win32::API->new( "kernel32", "GetProcAddress", "NP", "N" );
my $LoadLibrary = Win32::API->new( "kernel32", "LoadLibraryA", "P", "N" );
my $FreeLibrary = Win32::API->new( "kernel32", "FreeLibrary", "N" );

sub my_sprintf{
    if( @_ < 1 ){
        die "argument error";
    }

    my $hDll = $LoadLibrary->Call( "msvcrt" );
    my $sprintf = pack( 'L', $GetProcAddress->Call( $hDll, "sprintf" ) );   # sprintf is cdecl
    my $buf = "\0" x 1024;
    my $x86 ="";
    my $i = @_;

    while( $i-- ){
        $x86 .= "\x68" . $_[ $i ];      # push args
    }
    $x86 .= "\x68" . pack( 'P', $buf ); # push $buf
    my $n = ( @_ + 1 ) * 4;
    $x86 .= ""
.       "\xb8" . $sprintf               # mov eax, func
.       "\xff\xd0"                      # call eax
.       "\x81\xC4"                      # add esp, @_ * 4
.       pack( 'L', $n )
.       "\x33\xc0"                      # xor eax, eax
.       "\xc2\x08\x00"                  # ret
;

    $EnumWindows->Call( unpack( 'L', pack( 'P', $x86 ) ), 0 );
    $FreeLibrary->Call( $hDll );
    $buf =~s/\0.*$//;
    return $buf;
}

my $s = my_sprintf( pack( 'P', "%s, %s" ), pack( 'P', "Hello" ), pack( 'P', "World" ) );
print $s;

実行結果

C:\>xmax.pl
Hello, World

このように、用意しておいたバイト配列をEnumWindows APIのコールバック関数として渡してやることで、任意の機械語を簡単に実行させることができます。

ただ、熟練したバイナリアンでなければ機械語を一発で動かすことは難しく、たいていの場合は途中でプログラムが強制終了させられてしまいます。

そこで、もう少し効率的にデバッグする方法を紹介します。

printf デバッグ

まず、もっとも簡単な方法として、みんな大好きな printf デバッグで機械語を確認することにしましょう。

    $x86 .= ""
.       "\xb8" . $sprintf               # mov eax, func
.       "\xff\xd0"                      # call eax
.       "\x81\xC4"                      # add esp, @_ * 4
.       pack( 'L', $n )
.       "\x33\xc0"                      # xor eax, eax
.       "\xc2\x08\x00"                  # ret
;
    print unpack( 'H2' x length( $x86 ), $x86 );
    print "\n";

実行結果

C:\>xmax.pl
68d4764d0268b4764d026894764d02685c8b4c02b831bd9676ffd081c41000000033c0c20800
Hello,World

ごらんのとおり、実行される機械語が画面に表示されますので、どこで機械語の指定を間違えたのか一目瞭然になります。

超画期的です。

デバッガでアタッチ

printfによる目視デバッグでもあまり困らないのですが、あまりやりすぎると

よしおかさんに怒られちゃうので、きちんとデバッガを使うようにしましょう。使うデバッガ環境はもちろん Visual Studio です。

Visual Studioは、「C:\Windows\System32\vsjitdebugger.exe -p プロセスID 」とすることで、任意のプロセスをデバッガにアタッチすることができますので、Perlのなかから自身のプロセスIDを指定してこれを呼び出すことで、うまくデバッガにアタッチできそうです。

指定してこれを呼び出すことで、うまくデバッガにアタッチできそうです。

ただし、Perlのsystem関数を使ってそのままvsjitdebugger.exeを呼び出したのでは、デバッガ終了までperl側の処理がブロックされてしまい、デバッガが立ち上がっても継続してデバッグすることができません。

そこで、start コマンド経由で vsjitdebugger.exe を呼び出すことにします。

system("start", "vsjitdebugger.exe", "-p", "$$" );

こうすることで、startコマンドは vsjitdebugger.exe を起動すると速やかに終了し、Perl側では system は制御を戻すので、デバッガと並行してコードの実行を進めることができます。

ただし、このままではデバッガが起動しデバッグ対象プロセス(ActivePerl)にアタッチしてデバッグの準備ができるのを待つことなく、Perl側はどんどんコードの実行を進めてしまいますので、今度はデバッガの準備ができるまでPerl側のコードの実行を停止させる必要があります。

これには、Windows APIのIsDebuggerPresent関数を使います。

while( $IsDebuggerPresent->Call() == 0 ){
    sleep( 1 );
};

これで、デバッガがきちんとアタッチしていない間は有意なコードの実行を停止させることができます。

つぎに、x86バイナリコードにブレークポイントを置くわけですが、これは単純に int 3 を実行することでデバッガにブレークを通知できます。

my $x86 = "\xCC.....";

CPUがこの0xCCという機械語を実行すると、デバッガ側にはブレークポイントとして通知され、以降のコードを自由にデバッガ上で動かすことができます。

というわけで、さきの Hello, World の機械語部分をデバッガ上で実行するよう書き換えたコードを以下に示します。

#!/c/perl/bin/perl
use strict;
use warnings;
use Win32::API;

#include 
my $EnumWindows = Win32::API->new( "user32", "EnumWindows", "NN", "N" );
my $GetProcAddress = Win32::API->new( "kernel32", "GetProcAddress", "NP", "N" );
my $LoadLibrary = Win32::API->new( "kernel32", "LoadLibraryA", "P", "N" );
my $FreeLibrary = Win32::API->new( "kernel32", "FreeLibrary", "N" );
my $IsDebuggerPresent = Win32::API->new( "kernel32", "IsDebuggerPresent", "", "N" );

sub my_sprintf{
    if( @_ < 1 ){
        die "argument error";
    }

    my $hDll = $LoadLibrary->Call( "msvcrt" );
    my $sprintf = pack( 'L', $GetProcAddress->Call( $hDll, "sprintf" ) );   # sprintf is cdecl
    my $buf = "\0" x 1024;
    my $x86 ="";
    my $i = @_;

    $x86 = "\xCC";                      # int 3

    while( $i-- ){
        $x86 .= "\x68" . $_[ $i ];      # push args
    }
    $x86 .= "\x68" . pack( 'P', $buf ); # push $buf
    my $n = ( @_ + 1 ) * 4;
    $x86 .= ""
.       "\xb8" . $sprintf               # mov eax, func
.       "\xff\xd0"                      # call eax
.       "\x81\xC4"                      # add esp, @_ * 4
.       pack( 'L', $n )
.       "\x33\xc0"                      # xor eax, eax
.       "\xc2\x08\x00"                  # ret
;

    $EnumWindows->Call( unpack( 'L', pack( 'P', $x86 ) ), 0 );
    $FreeLibrary->Call( $hDll );
    $buf =~s/\0.*$//;
    return $buf;
}

system("start", "vsjitdebugger.exe", "-p", "$$" );
while( $IsDebuggerPresent->Call() == 0 ){
    sleep( 1 );
};

my $s = my_sprintf( pack( 'P', "%s,%s" ), pack( 'P', "Hello" ), pack( 'P', "World" ) );
print $s;

まとめ

• Perlに機械語埋め込むときでもデバッガ使ったほうが怒られないで済むよ！
• WindowsならVisual Studio最強ですよ!
• int 3は0xCC。バッドノウハウ万歳!

明日の最後のエントリーは・・・Yappoさんが締めくくってくれる予定？どんなネタか今から楽しみです！

既存の環境に対する不満

Perl のウェブアプリケーションを構築するにあたっては、リバースプロキシと mod_perl を組み合わせるか、あるいは FastCGI (ExternalServer) を利用するのが一般的だと思います。しかし、どちらをとっても、環境を構築して設定するのが難しいというのが個人的な不満でした (mod_redirect を設定したり mod_fastcgi にパッチをあててインストールしたり startup.pl を書いたり...)。自分が Plack の開発 (主に Server::Standalone と Server::Standalone::Prefork) に関わるようになったのも、そのイライラを解消したかったからです。

その目的は、ほぼ達成することができ、先週、会社で運用しているサービス「パストラック」のバックエンドを Apache + FastCGI から Apache (mod_proxy) + Plack::Standalone::Server::Prefork::Server::Starter へ切り替えました。

そこで今日は、Plack::Server::Standalone 系のモジュールを利用したウェブアプリケーションの開発と運用の実際について、その楽さ加減を宣伝したいと思います。

.psgi と plackup

Standalone 系のサーバの特徴は、Plack の Middleware と組み合わせて、単独で動作するウェブサーバを構築できるところです。パストラックの .psgi ファイルは、概ね以下のようになっています。/static 以下のファイルを静的コンテンツとして配信し、動的コンテンツは昔ながらの CGI::Application::Dispatch を用いて生成しています。

builder {
    enable 'AccessLog', format => 'combined';
    enable 'ConditionalGET';
    enable_if { $_[0]->{PATH_INFO} =~ q{^/static/\d+/} } 'Header', set=> [ 'Expires' => 'Tue, 31 Dec 2019 23:59:59 GMT' ];
    enable 'Plack::Middleware::Static', path => qw{^/static/}, root => $ROOT;
    enable 'Plack::Middleware::Static', path => qw{^/(?:favicon\.(ico|png)|robots\.txt)$}, root => "$ROOT/static";
    CGI::Application::Emulate::PSGI->handler(
        sub {
            MyApp->dispatch();
        },
    );
};

開発環境では、この .psgi ファイルを以下のようにして Plack::Server::Standalone で動かします。httpd を起動する必要も設定ファイルを書く必要もありません。plackup 自身が、上で述べたように静的コンテンツも含む完全なウェブアプリケーションとして動作します。また、-r オプションによって、コードを書き換えると自動的に再起動するようになるので、修正→テストのサイクルを素早く回すことができます。

% plackup -r index.psgi

運用環境への投入

運用環境では、上の .psgi ファイルを Plack::Server::Standalone::Prefork::Server::Starter (以下 PSSPSS) を利用して動かしています。サービスの起動スクリプト (daemontoolsで管理) は、以下のとおり。.psgi は開発用のものと全く同一。他に設定ファイルはありません。

#! /bin/sh

exec 2>&1
cd /var/webapp || exit 1
exec /usr/bin/start_server --port=80 -- /usr/local/bin/setuidgid www \
  /usr/bin/plackup -E production -s Standalone::Prefork::Server::Starter --max-workers=40 --max-keepalive-reqs=1 index.psgi

PSSPSS は、Plack::Server::Standalone ベースのマルチプロセス httpd である Plack::Server::Standalone::Prefork に、完全無停止での更新機能を追加した httpd です。ウェブアプリケーションのプログラムを書き換えた後に SIGHUP を送ることで、サービスを一切停止しないホットデプロイが可能です。この仕組みについては、詳しくは「Kazuho@Cybozu Labs: Writing Hot-deployable servers (introduction of Server::Starter)」をご覧ください。

自分は daemontools で管理しているので、以下のようにして SIGHUP を送っています。

# svc -h /servire/webapp

Plack::Server::Standalone::Prefork (とその子クラスであるPSSPSS) では、デフォルトで keep-alive がオンになるのですが、ここではリバースプロキシと組み合わせるために、keep-alive をオフにしています(--max-keepalive-reqs=1)。

ちなみにパストラックでは、この設定で 20〜40 リクエスト/秒ほどの動的コンテンツを XenServer 上で生成しています。

リバースプロキシとの組み合わせ

PSSPSS (あるいは Plack::Server::Standalone::Prefork) は単独でのウェブサービス提供も十分可能なポテンシャルを持っていますが、パストラックでは Apache (mpm_worker) ベースのリバースプロキシと組み合わせて運用しています。mpm_worker で同時接続数の上限を稼ぐ。それによって keep-alive オンでの運用が可能となり、ユーザーのレスポンスが向上するから、というのが理由です。

この場合の設定も簡単。plackup が単独で全コンテンツをサーブできるので、必要なのはリバースプロキシとキャッシュだけです。だいたい、以下のような設定で運用しています。

<VirtualHost _default_:80>
  ServerName webapp.example.com
  ErrorLog /var/log/httpd/webapp.example.com/error_log
  CustomLog /var/log/httpd/webapp.example.com/access_log combined
  CacheEnable disk /static
  <Location />
    Order allow,deny
    Allow from all
    ProxyPass http://webapp.local/
    ProxyPassReverse http://webapp.local/
    ProxyPreserveHost On
  </Location>
</VirtualHost>

まとめ

このように、Plack::Server::Standalone 系のモジュールを使うことで、開発から運用までのコストを低く抑えることが可能です。具体的には、

• 開発環境の構築が容易
• 開発環境と運用環境の差異が少ない (ので問題が発生しにくい)
• 設定項目が少ない
• 運用環境でのホットデプロイが簡単
• 全て HTTP ベースなので、問題の切り分けが容易

といったあたりになるでしょうか。大規模な案件で使うメリットがどれだけあるかは不明ですが、小〜中規模な開発では便利だと思います。一度お試しあれ。

PS. 明日は、ななしさんです。お楽しみに！

cpan DBIx::Skinny::Schema::Loader

■動的生成

Schemaクラスを以下のように書くと、ロード時にDBに合わせたSchema情報を設定します。

package Your::DB::Schema;
use base qw/DBIx::Skinny::Schema::Loader/;

__PACKAGE__->load_schema;

1;

通常、Schemaクラスでは use DBIx::Skinny::Schema; しますが、Schema::Loaderを使う場合はuse baseしてください。

load_schemaを呼ぶと、DBの中を見て、各テーブルのpkとcolumnsを設定するinstall_tableが実行されます。

それ以外の要素、例えばinflate/deflateやtriggerなどを設定したい場合は、

package Your::DB::Schema;
use base qw/DBIx::Skinny::Schema::Loader/;

install_table users => schema {
    trigger pre_insert => sub {
        my ($class, $args) = @_;
        $args->{ status } = 'hooked';
    };
};

__PACKAGE__->load_schema;

1;

のように書きます。install_tableは複数回に分けて書いてもいいので、ここに書いたtriggerとload_schemaが設定するpk, columnsの両方の設定が生きます。

load_schemaによる動的生成を使う場合の注意点として、Skinnyクラス（上の例だとYour::DB）にuse DBIx::Skinny setupでDBの接続情報を書いておくことが必要です。

newで接続情報を渡したりする場合でもやってやれなくはないのですが、無理矢理感があるので、そういったケースでは基本的には次の静的生成をお勧めしています。

■静的生成

まず、以下のようなスクリプトを書きます。publish_schema.plなど適当な名前で保存しておきましょう。

use DBIx::Skinny::Schema::Loader qw/make_schema_at/;
print make_schema_at(
  'Your::DB::Schema',
  {},
  [ 'dbi:SQLite:test.db', '', '' ]
);

そして、以下のようにすると、Your::DB::Schemaのファイルが書き出されます。

perl publich_schema.pl > lib/You/DB/Schema.pm

DBICと違ってSkinnyのSchemaは1ファイルで完結するので、直接ファイルを書き出すのではなく、標準出力に吐き出すようにしています。

make_schema_atは第2引数にオプションを指定して、出力するSchemaクラスのカスタマイズが出来ます。

例えば、先程のload_schemaのようなtrigger設定を入れるには以下のようにします。

use DBIx::Skinny::Schema::Loader qw/make_schema_at/;

my $before = << '...';
install_table users => schema {
    trigger pre_insert => sub {
        my ($class, $args) = @_;
        $args->{ status } = 'hooked';
    };
};
...

print make_schema_at(
  'Your::DB::Schema',
  {
    before_template => $before,
  },
  [ 'dbi:SQLite:test.db', '', '' ]
);

この他、install_tableブロックの後に指定の文字列を挿入するafter_templateや、install_tableブロックに任意のテンプレートを使用するtable_templateといったオプションがあります。詳細はPODをご覧ください。

PODには他にも動作の詳細やちょっとしたTipsを書いていますので、よかったら目を通してみてください（破滅的な英語ですが）。

このように、Schema::Loaderを使うとSchema定義を書く手間を軽減することが出来ます。個人的には、テーブル設計が流動的な開発初期はload_schemaによる動的生成を使い、ある程度落ち着いてきたらmake_schema_atによる静的生成に切り替えるといいんじゃないかと思ってます。

明日はDBIx::Skinny::InflateColumn::DateTimeを紹介します。

have a nice skinny days!:)

レプリケーションを使う

MySQL にはレプリケーション機能があるのはとても知られている事です。

レプリケーションの無い MySQL は、ブラウン管の無いブラウン管テレビくらいの物でしょう。

そして ORM でも切っても切れない物では無いでしょうか。

Data::ObjectDriver でも livedoor のどっかのサービスで自作 Driver 書いて使ってるとか

DBIC の世界でも DBIx::Class::Storage::DBI::Replicated なんて物があるようです。

もちろん Data::Model でも対応しています。

Driver::DBI::MasterSlave です。 Driver::DBI を使った事がある人ならとても簡単な物となっています。

  use Data::Model::Driver::DBI::MasterSlave;
  
  my $dbi_connect_options = {};
  my $driver = Data::Model::Driver::DBI::MasterSlave->new(
      # master の接続設定
      master => {
          dsn => 'dbi:mysql:host=master.server:database=test',
          username => 'master',
          password => 'master',
          connect_options => $dbi_connect_options,
      },
      # slave の接続設定
      slave  => {
          dsn => 'dbi:mysql:host=slave.server:database=test',
          username => 'slave',
          password => 'slave',
          connect_options => $dbi_connect_options,
      },
  );

  # base driver の設定をする
  base_driver $driver;

上記の用に master => $conf, slave => $conf という形で設定するだけです。 $conf の中身は先日紹介した Driver::DBI の設定と全く同じ物がつかえます。

仕組み

Driver::DBI も 内部的には DBI のインスタンスを使って DBI 接続を行っていて DBI::MasterSlave では DBI のインスタンスを2個作って、それぞれ master, slave 用として使います。

Driver::DBI は SELECT クエリでは r_handle を使い それ以外のクエリでは rw_handle を使っており、それぞれの handle にたいして master, slave の DBI のインスタンスを割り当てるので、うまい具合 master, slave でクエリを振り分ける事ができるのです。

注意

txn_scope を使ったトランザクション中は、全てのクエリが rw_master に向かいますので注意してください。

複数の slave を扱うにはどうするの?

DBIC の世界だと複数台の slave をうまいこと扱ってくれる仕組みがあるのですが Data::Model では、そのような仕組みはありません。

バグ?手抜き? いえいえ、元からこういう設計です。

そういった複数台の slave を持つ場合には lvs などを使って、より低いレイヤーにて分散環境を整えてください。

このような低いレベルでやるべき処理を Perl のレイヤでやるよりかは、それなりに実績がある低レイヤ処理するべきだと思っています。

しかも slave の分散クエリなんて lvs で十分事足りるし Perl のコード書くよりも高度な事ができるので良いです。

まぁ、インテグレーションというのは時と場合によって思うとおりの道具が使えないでしょうから、細かい要求などは Data::Model::Driver の自分向けに書いてくださいという事になります。この辺の詳しい話は後日書きます。

Q4M を使う

Data::Model の特色の一つとして Q4M 対応が行われているということです。

このあたりのエッセンスは3日目( http://perl-users.jp/articles/advent-calendar/2009/data-model/03.html )に紹介してますが、3日目は超応用編だったので今日は Driver::Queue::Q4M の使い方を紹介します。

Q4M とは

Q4M とは、サイボウズラボの奥一穂(以下略

スキーマ定義

スキーマ定義は、通常の定義と殆どおんなじ感じです。

    package TestQueue;
    use base 'Data::Model';
    use Data::Model::Schema;
    # Queue::Q4M の mixin が必須
    use Data::Model::Mixin modules => ['Queue::Q4M'];
    use Data::Model::Driver::Queue::Q4M;

    my $driver = Data::Model::Driver::Queue::Q4M->new(
        dsn => 'dbi:mysql:database=test'
    );
    base_driver $driver;

    install_model queue_test => schema {
        columns qw/ id job_name /;

        # as_sqls の為にも TYPE=Queue を入れとく
        schema_options create_sql_attributes => {
            mysql => 'TYPE=Queue',
        };
    };

Q4M 専用のメソッドを追加するために mixin を指定するのと CREATE TABLE 文の為に schema_options create_sql_attributes を指定します。

as_sqls で出来上がる SQL は下記のようになります。

CREATE TABLE queue_test (
    id              CHAR(255)      ,
    job_name        CHAR(255)      
) TYPE=Queue;

Q4M では index のサポートが行われていないので、 primary key などの事は忘れましょう。

もちろんユニーク制約なんてのも使えませんからね。

Queue を作る

Q4M の Queue を作るのはとても簡単です！

なんてったって普通の MySQL のテーブルの用に扱えるのが Q4M の良いところの一つなんで、普通に set メソッドして INSERT すれば良いんです.

    # queue を一つ作る
    $queue->set(
        queue_test => {
            id       => 1,
            job_name => 'get http://example.com/',
        },
    );

Queue を読む

Q4M を使う場合は queue_wait を使って dequeue してからデータを読むことが一般的ですが抜く、一応 Data::Model ごしでも Queue の内容を直接読むことが出来ます。

ただし primary key とかは無いので where とか使って見る必要があるでしょう。

index を使ってないですが、そもそも Q4M に Queue が大量に保存されてることはありえないので問題にならないでしょう。大量にあるんだったらお前のアプリの書き方がとち狂ってる。

    # queue を読む
    my($q) = $queue->get('queue_test');
    warn $q->job_name;

Queue の削除

普通は Q4M が勝手に削除するんですが、どうしても手動で消したい人の為に書いておきます。

基本的にはスキーマオブジェクトの delete メソッドを叩くだけです。

    # こういう delete はできない
    $q->delete;

    # 直接 query を吐いて delete する
    $queue->delete('queue_test', {
        where => [
            id => 1,
        ],
    });

    # DELETE FROM queue_test; はこれ
    $queue->delete('queue_test', {});

$q->delete のように Row オブジェクトの delete メソッドは primary key が無いテーブルには使えないため上記のコードのようなコメントになっています。

update

(略

dequeue する

Q4M では queue_wait を使って dequeue をします、細かいことはドキュメント読んでください。

まぁこんな SQL ですね。

mysql> SELECT queue_wait('high_priority_table', 'low_priority_table', 10);

これに相当する Data::Model の使い方としては queue_running メソッドを使います。

  my $queue = TestQueue->new;
  my $retval = $queue->queue_running(
      high_priority_table => sub {
          my $row = shift;
          # 何かの処理
      },
      low_priority_table  => sub {
          my $row = shift;
          # 何かの処理
      },
      timeout => 10,
  );

queue_running の引数に table_name => CODE リファレンス という構造の HASH を渡してあげます。

timeout だけは例外的に queue_wait に渡すタイムアウトを指定します。

table_name の queue table に enqueue されると、オーナーモードになった行の Row オブジェクトを引数としてコードを実行します。

簡単ですね。

queue_abort

Q4M では queue が何らかの処理で以上になった時に queue の先頭に enqueue してくれる queue_abort という物があります。

もちろん Data::Model でも使えます。

    my $ret = $queue->queue_running(
        queue_test => sub {
            my $row = shift;
            warn $row->id;
            warn $row->job_name;
            $queue->queue_abort;
        },
    );
    warn $ret;

このようにスキーマオブジェクトから生えている queue_abort メソッドを呼ぶだけです。

$ret の内容は、 queue_running が失敗してるだけ undef になります。

ちなみに CODE リファレンス中で die してしまった時も内部的には queue_abort されます。

    eval {
        my $ret = $queue->queue_running(
            queue_test => sub {
                die "abort"; # ここで queue_abort が呼ばれる
            },
        );
    };
    $@ and warn $@; # 'abort' と表示
    warn $ret;

ここの $ret も undef です。

queue_end

Q4M で queue の正常終了を表す queue_end という物が用意されています。

Data::Model では CODE リファレンスの中だけが Q4M のオーナーモードでいるという設計になっているので、 CODE リファレンスの中で queue_abort が呼ばれないまま return した時に自動的に queue_end が呼ばれます。

    my $ret = $queue->queue_running(
        queue_test => sub {
            return; # ここで queue_end が呼ばれる
        },
    );
    warn $ret; # 処理した queue テーブル名を表示

queue の処理が成功した場合に queue_running は queue_wait で処理した queue table 名を戻り値として返します。

queue_running と queue_abort はどこから来たの?

冒頭に Queue::Q4M mixin を使う設定をすると書いてありますが、この Mixin がスキーマオブジェクトに queue_running と queue_abort メソッドを生やしているんです。

単純に Driver に処理を delegation してるだけです。

まとめ

今日は、レプリケーションと Q4M を Data::Model で使う為にどうするかといった事を紹介しました。

サックリ紹介するつもりが長文になって DNBK です。

明日はキャッシュ戦略について紹介します。