まえおき

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

もうすでに 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 を締めくくりましたが、そんなんで良いんじゃないかとおもいます。

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

まえおき

というわけで、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. 明日は、ななしさんです。お楽しみに！

フォームの検証

web アプリケーションを作っていると、どのページでも出てくる入力項目ってあると思います。

会員登録時のパスワード項目とログイン時のパスワード項目とユーザ情報変更時のパスワード項目と退会時に求められるパスワード入力項目、リマインダで再設定するパスワード入力項目……などなど。

これらの項目がフォームごとにルールを指定してると、登録時は半角英数字と記号のみで6文字から14文字なのに、ログイン時は半角英数字のみで4文字から12文字になってたりとかおかしなことになったりしないでしょうか？
「仕様書を見るから大丈夫だよ」という声も聞こえてきそうですが、定義はまとめておいたほうが変更しやすくて良いですよね。

そこで FormValidator::LazyWay です。検証ルールをフォームごとにせずに項目ごとにして怠けましょう。

設定

こんな感じで設定を書きます。

my $config = {
    rules => [ 'Email', 'String' ], # 使用するルール
    setting => {
        strict => {
            # Email は Email の書式でないとだめ
            email    => {
                rule => ['Email#email']
            },
            # password は4文字から12文字で半角英数字のみ
            password => {
                rule => [
                    {   'String#length' => {
                            'min' => '4',
                            'max' => '12'
                        }
                    },
                    'String#ascii'
                ]
            },
        }
    },
    lang   => 'ja',
    # バリデーションに引っかかったときのメッセージに出力するラベル名
    labels => {
        ja => {
            email    => 'メールアドレス',
            password => 'パスワード'
        }
    },
};

使用

そしてこんな風に使います。

use FormValidator::LazyWay;

# この $fv オブジェクトはサイト全体で使い回すと良いよ
my $fv =  FormValidator::LazyWay->new($config);

# $q は CGI とか Catalyst::Request とかのオブジェクト
my $result = $fv->check($q, {
    required => [qw/email password/],
});

フォームによって必須項目変えたければ変えればいいです。

たとえば、ブログ的なもので登録時は内容のみ必須でタイトルはオプショナル。

my $result = $fv->check($q, {
    required => [qw/body/],
    optional => [qw/title/]
});

そして検索時は両方オプショナル。

my $result = $fv->check($q, {
    optional => [qw/title body/],
});

各項目の検証ルールはすでに決まってるので、使うときはどの項目を検証すればいいかだけ考えればいいですね。

検証結果

検証結果には FormValidator::LazyWay::Result オブジェクトが返ってきます。

# $result が FormValidator::LazyWay::Result オブジェクト
my $result = $fv->check($q, {
    required => [qw/nickname email password/],
    optional => [qw/message/]
});

if ( $result->has_error ) {
    print Dumper $result->error_message;

    # 検証結果に応じてメッセージを自動生成してくれます。
    # このメッセージは設定で指定した label と
    # ルールモジュールで設定された内容を掛け合わせてます。
    # $VAR1 = {
    #   'email' => 'メールアドレスが空です。',
    #   'password' => 'パスワードには4文字以上12文字以下が使用できます。'
    # };
}
else {
    # OK!
    # 検証されたデータは $result->valid にハッシュとして持ってます。
    # 検証後はこの valid で取り出した値を使いましょう
    print Dumper $result->valid;
}

同じ項目で違うルールを指定したい

設定で level を変えてあげれば可能です。

ハッシュで書くと長いので YAML で書きますね。

config:
  setting:
    strict:
      email:
        rule:
          - Email#email
    loose:
      email:
        rule:
          - Email#email_loose

こんな風に strict と loose というのを用意してあげましょう。そして使うときはこんな感じ。

my $result = $fv->check( $q,
    {   required => [qw/email/],
        level => {
            email => 'loose'
        }
    }
);

email 項目が loose の方の設定で検証されるようになるよ。

項目をマージして検証

複数の入力項目から一つの値にして検証もできます。たとえば、年月日がそれぞれ別項目で、妥当な日時か検証したいとき。

config:
  setting:
    merge:
      date:
        format: "%04d-%02d-%02d"
        fields:
          - year
          - month
          - day
    strict:
      date:
        rule:
          - DateTime#date

year, month, day という項目を %04d-%02d-%02d というフォーマットで date 項目を作って、date 項目に対して妥当な日時かどうか検証します。

filter -> rule -> fix

FormValidator::LazyWay は、項目の検証の前後にフックを持っていて、検証前に項目の値の値と検証後の値の変更が可能です。

たとえば、ハイフンっぽい文字列をハイフンに統一したあとに、妥当な日時かどうか検証して、DateTime オブジェクトにして返すとか。

  setting:
    strict:
      date:
        filter:
          - Unify#hyphen
        rule:
          - DateTime#date
        fix:
          - DateTime#format:
              - '%Y-%m-%d'

問題無く検証できれば $result->valid->{date} が DateTime オブジェクトになって返ってくるよ。

そのほかにもメッセージのカスタマイズとか、param メソッド持ってないただのハッシュの検証とか色々機能があります。

日本語の POD もあるのでご参照いただければ幸いです

明日は……誰か書きませんか！

JPerl Advent Calendar hacker track の明日を作るのはあなたです！

はじめに

今日は、Windows環境以外の人は何にも関係ない、モジュール Win32::Unicode をご紹介しようとおもいます。

しかもまた文字コード関連の話ですね！！にEncodeでラクラク日本語処理を読んでから詠むと、より理解が深まるかもしれません。

Win32::Unicodeって？

Windows で perl を使う場合の選択肢としては ActivePerl と Strawberry Perl の二種類があげられます。

どちらも Windows 用にカスタマイズされたものなのですが、悲しいことにどちらの Perlを使っても Unicode 文字の含まれたファイルが扱えません。

でもそれだと悲しいので、Unicode なファイルも扱えるように書いてみたというわけです。

Unicode 文字の含まれたファイルはやっかい

Windowsでは1つのファイルに対して上記3種類のものが扱えます。

• cp932
• 8.3形式 (PROGRA~1とか)
• Unicode (UTF-16LE)

基本的に Perl は一番最初の cp932 としてファイル名を扱うようになっています。しかし、Windowsのマルチバイト環境では、Unicode のファイルが許されています。

しかし、Unicode 文字があるファイルは「?」となってしまい、Windows のシステムからすればそんなファイルはないので読み取れません。

iTunesとかで海外の曲を買ってると、知らず知らずのうちの、 Unicode ファイルができている、何てこともあります。

ためしに、「明日の天気は☃.txt」というファイルが含まれているディレクトリのリストを表示してみましょう。

>perl
opendir my $dh, '.' or die $!;
print join "\n", readdir $dh;
closedir $dh;
__END__
.
..
今日の天気は?.txt

「&;#9731;」は cp932 に存在しない文字なので「?」に変換されてしまいました。

もちろん、 Perl プログラムに cp932 で埋め込むことはできません。 UTF-16LE で書いたところで、Perl自体がまともに動かないのでそれも不可能です。

Win32::Unicode を使う

さて、それではどうすれば Unincode ファイルを扱えるのでしょうか？実は Windows 自体には Unicode ファイルを扱う API が用意されているのです。

そいつを使ってやれば、ちゃんと Unicode ファイルの操作ができます。Window の API を Perl からたたくのは、 Win32::API を使えば実現できます。

でも、こいつは Perl の書き方とはかけ離れているので、日常的に使うにはとってもめんどくさいです。

Win32::Unicode は Perl の書き方とほぼ同じように Unicode ファイルを扱えるように Win32::API をラップしたモジュールです。

use すると、大量の関数をエクスポートするのが特徴です。しかも、デフォルトでは、COREの関数をoverrideしないように、ほとんどのものに「W」というのがついています。

でもそれだとダサいので、最後のほうで「Win32::Unicode::Native」っていうのを紹介します。

Win32::Unicode では、すべての関数で flagged utf8 を使うことにしているので、モダンな気持ちを味わいながら書くことができると思います。

Win32::Unicode::File;

Unicode 文字のファイルの読み書きができる IO::File っぽいインターフェースを持ったモジュールです。

ファイルの読み書きだけでなく、 rename、copy、unlink などもあります。

それでは、さっき開けなかった「明日の天気は☃.txt」に何か書き込んで見ましょう。

use strict;
use warnings;
use utf8;
use Win32::Unicode::File;

my $fh = Win32::Unicode::File->new;
open $fh, '>', "明日の天気は\x{2603}.txt";
binmode $fh, ':encoding(cp932)';
print $fh "こんにちわ！こんにちわ！\n";
close $fh;

とっても簡単ですね！！もちろん読み込むこともできます。

Win32::Unicode では-X 演算子を PP で実装する方法がわからなかったので、「file_type」という関数を使わなくてはなりません。さらに、ファイルサイズを取得する場合は、-s ではなく file_size を使用します。

そのかわり、Windows 固有のファイル属性の判定ができ、なおかつ、重ね打ちも可能です。

このあたり、何かいい手段があれば教えていただけると幸いです。

if (file_type rhf => $file_name) {
    # (読み込み専用で隠し属性のファイル)
}

my $size = file_size $file_name # -s $file_name と等価

あと、まだstatとかflockとかが未実装だったり、4GB以上のファイルがたぶん扱えなかったりしますが、そのうち実装されるんじゃないかと思います。

Win32::Unicode::Dir;

次はディレクトリ周りです。使いかたは Win32::Unicode::File と大体一緒です。

こっちにも find、mkpath、cptree、mvtree など、よく使う関数も一緒にエクスポートします。

use strict;
use warnings;
use utf8;
use Win32::Unicode::Dir;

my $dh = Win32::Unicode::Dir->new;
$dh->open('.');
print join "\n", $dh->readdir;
$dh->close;

こんな感じで使います。

でもこれを実行すると、

Wide character in print at readdir.pl line 8.
.
..
譏取律縺ｮ螟ｩ豌励・笘・txt

とかいって文字化けしてしまいます。

これは、readdir で帰ってくる文字が、 flagged utf8 だからなので当然といえば当然です。

でも、

use strict;
use warnings;
use utf8;
use Win32::Unicode::Dir;

binmode STDOUT => ':encoding(cp932)'; # 追加

my $dh = Win32::Unicode::Dir->new;
$dh->open('.');
print join "\n", $dh->readdir;
$dh->close;

としたところで、

.
..
"\x{2603}" does not map to cp932.
明日の天気は\x{2603}.txt

と、怒られてしまいます。

なんだかここまでくれば、コマンドプロンプトにも「明日の天気は☃.txt」って表示してほしいなーと思いました。

で、実はこのファイルがあるディレクトリで「dir」するとなんと普通に「明日の天気は☃.txt」って表示されるんです！！

ということは、コマンドプロンプトにも Unicode を表示する API があるということですね。

Win32::Unicode::Console

なので、つくりました。

Win32::Unicode::Console はコマンドプロンプトに Unicode 文字を表示できます。

printW printfW sayW dieW warnW という関数がエクスポートされます。

これらはすべて、 flagged utf8 を受け取ります。

これをつかってさっきのやつを書き換えると

use strict;
use warnings;
use utf8;
use Win32::Unicode::Dir;
use Win32::Unicode::Console;

binmode STDOUT => ':utf8'; # リダイレクトのため

my $dh = Win32::Unicode::Dir->new;
$dh->open('.');
printW join "\n", $dh->readdir;
$dh->close;

.
..
明日の天気は☃.txt

おおお！無事に表示されましたね！！

ちなみに、リダイレクト時には、通常の print が使用されるため、binmode しておいたほうがいいでしょう。

Win32::Unicode::Error

次はエラーメッセージです。とはいっても、これがエクスポートするのは errorW のみです。

位置づけとしては、「$!」の代わりに使うという感じです。

これまた、$! を書き換える方法がわからなかったので、仕方なく という感じです。($! にはエラーコードを示す数値のみ代入でき、文字列を入れることはできない。)

メッセージはWindow API のエラーメッセージとなります。マルチバイト環境では日本語が返ってくるので、dieW errorW という風に使います。

use strict;
use warnings;
use utf8;
use Win32::Unicode::Error;
use Win32::Unicode::Console;
use Win32::Unicode::File;

my $fh = Win32::Unicode::File->new;
open $fh, '<', '存在しないファイル' or dieW errorW;
print <$fh>;
close $fh;

これを実行すると、

指定されたファイルが見つかりません。 at errorW.pl line 8

みたいになります。

Win32::Unicode

ここまで、４つぐらいのモジュールが登場しましたが、毎回全部 use するのはめんどくさいので、 use Win32::Unicode します。

これで、今までのモジュールがすべでロードされ、さらにそれぞれの関数もすべてエクスポートされます。

Win32::Unicode::Native

でも、ここまで書いておいていうのもあれですが、正直「W」とないわー。

しかもファイルオープンとかも new しないいけないしめんどいなー。

どうにかならんかなー。ってことで、 Win32::Unicode::Native です。

こいつをuse すると標準関数を override します。とはいっても、CORE::GLOBAL::* を書き換えるわけではなく、単純に同名の関数をエクスポートして上書きします。

use した範囲だけ適用されるので、ほかのモジュールなどには影響しません。

唯一の例外が、 STDOUT です。これだけは、 Win32::Unicode::Console::Tie というモジュールに tie しているため、すべてに影響します。

use strict;
use warnings;
use utf8;
use Win32::Unicode::Native;

print "flagged utf8な文字も普通にいける";

# Win32::Unicode::File->newとかしない
open my $fh, '>', '森鷗外.txt' or die error;
print $fh "ほげほげ";
close $fh;

# Win32::Unicode::Dir->newとかしない
opendir my $dh, "\x{2600}" or die error;
say join "\n", readdir $dh;
close $dh;

ほとんど Perl の記法と一緒ですね！！

ちなみに、use Win32::Unicode '-native'としてもOKです。

Win32::Unicodeは遅い

Win32::Unicode は普通に遅いです。

Perl がネイティブにやってくれるところをわざわざ PP で再実装しているので当然なのですが。

Unicode のファイルをPerlで扱う必要がまったくない場合は、使わないことをお勧めします。

また、当然のことながら(いないとはおもいますが・・・)モジュールなどには使わないほうがいいでしょう。

個人的に Windows 上で動かしたいスクリプトなどで重宝するんじゃないかなーと思っています。

まとめ

Windows で Unicode のあれこれを扱えるモジュールを紹介しました。

このモジュールは、Windows でファイル操作をしているときに、扱えないファイルがあって、なんだか悲しかったのでつくりました。

本来であれば、Perl がわで実装されるべきではないかと思っていますが、影響範囲や実装方法などが、なかなかややこしいと思うので、昨今まで実装されていないのではないでしょうか？

将来的にはネイティブに扱えるようになるといいなーと思います。

また、現在は PP で書いていますが、 Win32 API をラップして使っているだけなので、XS で書いたほうがもっといい感じに実装できるでしょう。

XS かけるようになったら挑戦してみたいと思います。(そのときに Windows を使っていればね！)

というわけで、明日は vkgtaro さんです！！風のうわさでは仙人になるのではないかとのことですが、本当のところはどうなんでしょうか？

どんな話をしてくれるのか今からとっても楽しみですね・・・！！

SEE ALSO

http://subtech.g.hatena.ne.jp/miyagawa/20070513/1178988848

http://subtech.g.hatena.ne.jp/miyagawa/20070513/1179038019

http://subtech.g.hatena.ne.jp/miyagawa/20070815/1187134943

http://subtech.g.hatena.ne.jp/miyagawa/20070815/1187134943

http://xaicron.web.fc2.com/misc/presen/20091120/index.html

what is Module::Setup?

Module:Setup とは miyagawa さん作の pmsetup を CPANize した物です。

で、 pmsetup は何かというと Module::Starter などのモジュール開発を始める上の雛形を便利な感じで作ってくれる物です。

まぁ pmsetup でも良かったんですが、みんな好き勝手にオレオレ pmsetup を作り出してて無駄かなと思ったので CPANize したのでした。

how to use Module::Setup

さぁ Module::Setup を使ってみましょう。使うには Module::Setup をインストールしといてください。

最新版は 0.07 です。必要におうじて cpanf で入れてください。

インストールすると module-setup というコマンドが適当な bin の中にインストールされるので、これを使って操作を行います。

インストールしてすぐにつかえるというワケではなくて、最初に初期化を行わないとなりません。

初期化には module-setup コマンドに --init というオプションを与えます。

]$ module-setup --init
Creating directory /Users/username/.module-setup
(略)
Creating directory /Users/username/.module-setup/flavors/default/template
Do you use SVN? [yN] [n] 
Do you use SVK? [yN] [n] 
Do you use Git? [yN] [n] y
You chose version control system: Git
Your name:  [Default Name] 名前を入力
Your email:  [default {at} example.com] メールアドレスを入力
Dump config /Users/username/.module-setup/flavors/default/config.yaml

だいたいこんな感じです。

途中で "Do you use " と聞いてる部分では、あなたが使いたい VCS のところで y を入れてください。

Your name と Your email は、作成する Module やら README やらで使われるので正しく入れておきましょう。

作成ログを見れば分かりますが ~/.module-setup に Module::Setup 用のファイル構造が作成されます。

Module::Setup では flavor という単位で作成するモジュールの雛形を複数保存しておくことができます。

今回は Default flavor を使いましたが、例えば XS の為を flavor を作りたい場合には、 Flavor のモジュール名と flavor 名をコマンドラインに与えます。

]$ module-setup --init --flavor-class=XS xs
Creating /Users/username/.module-setup/flavors/xs/template/Makefile.PL
(略)
Your name:  [Default Name] 名前を入力
Your email:  [default {at} example.com] メールアドレスを入力
Dump config /Users/username/.module-setup/flavors/xs/config.yaml

--flavor-class というオプションで flavor class を指定して最後の引数で作成する flavor の名前を指定します。

作成する flavor の名前はあなたの好きな物を選べますが、 flavor class は Module::Setup::Flavor::* の中のものを指定します。

今のところ以下の flavor class が標準で入っています。

$ ls lib/Module/Setup/Flavor
CatalystStarter.pm      Default.pm              PBP.pm                  XS.pm
CodeRepos.pm            GitHub.pm               SelectVC.pm

もし、あなたの名前空間で flavor class を作っていたら --flavor-class=+YourModule::FlavorName とかいう感じで指定できます。

雛形を作る

初期化がすんだら雛形を作りだす事ができます。

$ module-setup モジュール名

という感じで module-setup コマンドを叩くと、モジュール名の雛形がカレントディレクトリに作成されます。

$ module-setup My::Module
[1]: default
[2]: xs
Select flavor: [1] 

ここまでのステップを踏むと default と xs という flavor が install されていますので、ここでどの flavor を使うかの選択肢がでます。

ここでは 1 の default を選びましょう。

Select flavor: [1] 1
You chose flavor: default
Creating directory My-Module
Creating My-Module/.shipit
Creating My-Module/Changes
Creating My-Module/Makefile.PL
Creating My-Module/MANIFEST.SKIP
Creating My-Module/README
Creating My-Module/lib/My/Module.pm
Creating My-Module/t/00_compile.t
Creating My-Module/xt/01_podspell.t
Creating My-Module/xt/02_perlcritic.t
Creating My-Module/xt/03_pod.t
Creating My-Module/xt/perlcriticrc
Creating My-Module/.gitignore
Check Makefile.PL? [Yn]  [y] 

こんどは、 Makefile.PL を使って make test をして正しく雛形が出来ているかを聞かれています。

まよわず y だ

Check Makefile.PL? [Yn]  [y] y
(略
Git init? [Yn]  [y] 

make test が無事実行できたら git init を実行して git repository を作るかを聞いています。

なぜ git かというと、最初の module-setup --init の例で git を選んでいたのです。

せっかく git をえらんだので y です

Git init? [Yn]  [y] y
Initialized empty Git repository in /Users/username/p5-Module-Setup/My-Module/.git/
The following paths are ignored by one of your .gitignore files:
MANIFEST
Use -f if you really want to add them.
fatal: no files added
Created initial commit 277e984: initial commit
 12 files changed, 137 insertions(+), 0 deletions(-)
 create mode 100644 .gitignore
 create mode 100644 .shipit
 create mode 100644 Changes
 create mode 100644 MANIFEST.SKIP
 create mode 100644 Makefile.PL
 create mode 100644 README
 create mode 100644 lib/My/Module.pm
 create mode 100644 t/00_compile.t
 create mode 100644 xt/01_podspell.t
 create mode 100644 xt/02_perlcritic.t
 create mode 100644 xt/03_pod.t
 create mode 100644 xt/perlcriticrc
$

無事プロジェクトが出来ました。

$ ls My-Module/
Changes         MANIFEST        MANIFEST.SKIP   Makefile.PL     README          lib             t               xt

Module::Setup では、基本的にモダンでかつ実用的な雛形を標準で用意しているので、 module-setup --init をしたあとは気軽にモジュール作成を行うことができます。

もし標準の雛形が気に入らなければ ~/.module-setup/flavors/default/template/ 以下がひな形のファイル構造が入っているので、これ以下のファイルを編集することによってお気に入りの雛形にすることができます。

もちろん改造した雛形は --pack オプションによっていつでも flavor class にすることができます。

$ module-setup --pack MyFlavor default

package MyFlavor;
use strict;
use warnings;
use base 'Module::Setup::Flavor';
1;

=head1

MyFlavor - pack from default

また、こうして flavor class を開発するための便利オプションなども充実しているのですが紙面が足りなさすぎるので perldoc Module::Setup とか、それ以下のモジュールのドキュメントを詳しくよんでね！

0.07 の新要素

ながらく 0.06_01 だったのですが、先程 0.07 を shipit しました。

一番大きい要素を紹介します。

add Helper support

いわゆる Catalyst::Helper を作るのに便利な Helper サポートを追加しました。

Module::Setup::Helper になってます。

これはさらに hacker 向けではあると思うので、ここでは説明しませんが Ark の setup script などに使うと良いでしょう。

XS flavor

XS なモジュールを書くための便利な flavor が追加されています。

おそらく id:gfx がいい感じにモダンな雛形にしてくれるとおもいます！

GitHub flavor

GitHub ユーザ向けの flavor が追加されています。

$ module-setup --init --flavor-class=GitHub
(略
use readme_pod_from? (depend Module::Install::ReadmePodFromPod, installed 0.01 [Yn]  [y] 
use githubmeta? (depend Module::Install::GithubMeta, installed 0.10 [Yn]  [y] 
use readme_markdown_from? (depend Module::Install::ReadmeMarkdownFromPod, not installed [Yn]  [y] n
use readme_from? (depend Module::Install::ReadmeFromPod, installed 0.06 [Yn]  [y] 
github repository name format:  [p5-%s] 
Dump config /Users/ko/.module-setup/flavors/github/config.yaml

という感じで setup します。

途中で聞いているのは perl ./Makefile.PL をした時に、メインのパッケージから README ファイルを作るかどうか聞いています。

3種類ありますが、普通の README か pod 形式化 markdown 形式かというのが選べます。

全部 CPAN から手に入ります。

もう一つ GithubMeta を使うかどうかも聞いています。

これは META.yml のデータの元を GitHub のメタデータから作れる物です。

最後の github repository name format は、雛形作成時に GitHub のリポジトリを作るときのリポジトリ名のフォーマットを決めます。

作ったモジュールの名前が %s に置換されます。

実際に使う時は以下のようになります。

$ module-setup My::GitHub
[1]: default
[2]: github
[3]: xs
Select flavor: [1] 2
You chose flavor: github
Creating directory My-GitHub
Creating My-GitHub/.shipit
(略
create GitHub repository? [Yn]  [y]
github repository name:  [p5-My-GitHub]
github repository description:  [Perl Module of My::GitHub]
github repository homepage:  []
create private repository? [yN]  [n]
include /Users/username/p5-Module-Setup/My-GitHub/inc/Module/Install.pm
(略
 create mode 100644 xt/03_pod.t
 create mode 100644 xt/perlcriticrc
try git push to GitHub? [Yn]  [y]
Enter passphrase for key '/Users/username/.ssh/id_dsa': 
Counting objects: 19, done.
Compressing objects: 100% (16/16), done.
Writing objects: 100% (19/19), 2.47 KiB, done.
Total 19 (delta 1), reused 0 (delta 0)
To git@github.com:yappo/p5-My-GitHub.git
 * [new branch]      master -> master

という感じで、実際に GitHub 上にリポジトリを作って、作りたてのリポジトリに雛形を push できます。

さすがに作りたての物を push するなんて誰得すぎるけどついでに作っといた反省しない。

その他

本当に Module::Setup はできることが多すぎて紹介しきれないんですが、例えば Helper suppoert を使わなくとも Module::Setup をあなたのモジュールに組み込むこともできる、組み込まれることを想定して作りこんであるので hack しがいがあると思います。

大抵のことはドキュメントに書いてあるつもりですし、もし不明点があれば僕を捕まえて聞いてみてください。

おわりに

ということで shipit したての Module::Setup のご紹介でした。

あしたは Module::Setup 0.07 の shipit 作業を物理的に行なってくれた xaicron さんです。

なんか、この文章書いてたら懇談会のおわりのじかんっぽいんですけど、この補填は kan さんのお寿司であてたいとおもいます。

利用例

モジュールがインストールしてあれば、DSNと一緒に渡すアトリビュートでRootClassと文字コードを指定するだけで利用できます。

use DBIx::Encoding;

my @dsn = (
   'dbi:mysql:host=localhost;database=mysql;mysql_socket=/tmp/mysql.sock;',
   'root',
   '',
   {
       RootClass => 'DBIx::Encoding',
       encoding  => 'cp932',
   },
);

my $dbh = DBI->connect(@dsn) or die;

このように記述するだけで、このDBハンドルメソッドあるいはステートメントハンドルメソッドで実行するクエリに関して

• データ取得の場合は指定文字コードでdecode
• 作成、更新の場合は指定文字コードでencode

という操作を行ってくれます。

このモジュールはDBIのサブクラスで、内部的にはDBIの各メソッドをオーバーライドして、それぞれを呼ぶ直前/直後にencode/decodeする形で動作します。

アトリビュートで指定するので、DBICなどのO/Rマッパから利用する事も可能です。

おわりに

「え、それってMySQLならset namesして、mysql_enable_utf8指定すれば終わりじゃないの？」という突っ込みをしようとした方、その通りだと思います。

DBDやデータベースが提供してくれる機能で事が足りる場合は、そちらを利用する事をおすすめします。

このモジュールは、「データベースのバージョンが非常に古かったり、あるいはあまり手を付けられない境遇で、文字コードの変換とflagの扱いをちゃんとしたい」という要求を満たすために作ったものです。

多分にBKなモジュールではありますが、同じような境遇でお悩みの方への一つの解となれば幸いです。

おことわり

現在 CPAN に上がっている Sub::Pipe のコードは dankogai さんから寄贈していただいたものですが、元になった実装は 自分の blog で書いたもの なので、ここでは自分のモジュールとして紹介させていただきます。

これはなに?

Sub::Pipe は非常に小粒なモジュールです。どれぐらい小粒かというと、本質部分は

package Sub::Pipe;
use overload '|' => sub { $_[0]->( $_[1] ) };
sub joint(&) { bless $_[0], __PACKAGE__ };

この 3行のみ、というぐらい小粒なわけですが、なかなかおもしろいモジュールじゃないかと思っています。

Sub::Pipe を使うと、UNIX pipe のような記法で適用する関数を作成できます。

use Sub::Pipe;
sub trim {
    joint {
        my $str = shift;
        $str =~ s/^\s+|\s+$//g;
        return $str;
    }
}
$foo = " foo " | trim;   # is $foo, "foo"

これは文字列の前後の空白を除去する trim という関数を用意した例です。

joint は | で適用できるオブジェクトを返すので、変数に代入して使ったり

$uc = joint { uc $_[0] };
"foo" | $uc;   # FOO

直接 joint { CODE } を適用することも可能です。

"foo" | joint { uc $_[0] }; # FOO

引数を取りたい場合はこう書きます。

sub replace {
    my ($regex, $to) = @_;
    joint {
        my $str = shift;
        $str =~ s/$regex/$to/g;
        return $str;
    };
}

"abcdefg" | replace("abc", "ABC");  # ABCdefg

なにがうれしいの?

さて、これでは単に変態的な記法が追加されただけではないか、という疑問はごもっともです。

これはもともと Text::MicroTemplate (T::MT)というテンプレートエンジン内で、Template-Toolkit (TT) のようなフィルタ記法が使いたくて考案したものでした。

TT では

[% value | repalce("foo", "bar") | uri %]

のように、値の後ろに | でフィルタを並べて適用、という記法が使えます。

この記法は表示される対象である値が先頭に書かれているのが読みやすい。

T::MT は Perl がそのまま書けるのでとても柔軟で高速なのですが、以下のように書かざるを得ないため、対象の値が何なのかが一見して分かりにくいなあと思ったのでした。

<?= uri( replace( $value, "foo", "bar" ) ) ?>

ここで Sub::Pipe を使えば

<?= $value | replace("foo", "bar") | uri ?>

のようにできますよね。

仕組み

さて、Sub::Pipe はどのような仕組みでこの (変な) 記法を実装しているのかといいますと、『演算子オーバーロード』を使っています。詳しくは perldoc overload をご参照ください。(日本語訳は 5.6.1 のものですが こちらにあります)

ソースコードをみていきましょう。

sub joint(&) { bless $_[0], __PACKAGE__ };

まず joint はコードリファレンスを引数に取り、それを bless した値を返すことで、関数の挙動をオブジェクト化します。

オブジェクトを作る場合はハッシュリファレンスを bless することが多いと思いますが、リファレンスならなんでも bless 可能なんですね。

そして演算子オーバーロードを使うと、あるパッケージのオブジェクトに対して、ある演算子が適用された場合の挙動を変更することができます。

use overload '|' => sub { $_[0]->( $_[1] ) };

ここでは通常 bit 演算の OR に使われる二項演算子 | を overload しているので、Sub::Pipe のオブジェクトに対して | が実行されると、sub { $_[0]->( $_[1] ) } が呼び出されます。

そこで、第1引数 $_[0] (これは bless されたコードリファレンスであるオブジェクト自身) に対して、第2引数 $_[1] (これは | の演算が適用される値です) を引数に与えて実行、という処理をしています。ややこしいですね!

A | B という演算なのに $_[0] が B で $_[1] が A なのはどうしてかというと、オブジェクトメソッドの最初の引数は常にそのパッケージのオブジェクトである必要から、引数の順序が入れ替わっているためです。

入れ替わっているかどうかは、$_[2] の値で判断できます。真なら入れ替わっていて、偽なら入れ替わっていない、という意味になりますがここも詳しくは perldoc overload の "Calling Conventions for Binary Operations" の項をご覧ください。

# Sub::Pipe の場合はオブジェクト同士を | で演算することはありえないため、常に入れ替わっているものとみなして扱っています

他に overload を使っているモジュールは?

例えば DateTime がそうです。日付を < や > で比較したり、+ で DateTime::Duration を足したりできるのは overload のおかげです。

他にも、オブジェクトを足したり引いたり比較したりできるモジュールは多々ありますよね。

まとめ

以上 UNIX pipe のような記法で関数適用を可能にする Sub::Pipe の紹介でした。

正直、普通のスクリプト内で使うのは止めたほうがいいでしょうが、テンプレート内の DSL としてはなかなか使えるんじゃないかと思っています。

明日は myfinder さんです。お楽しみに!

Perlハッカーに最も必要なもの

ここでなぞなぞです。Perlハッカーにとって最も必要なのは何でしょうか?

Perlそのもの、ですよね。

そうなんです。どんなすばらしいPerlモジュールも、Perl本体がなければ動きません。Perlはモジュールがなくてもなんとか動きますが、その逆は真ではないのです。

自分専用Perlを持つべき理由

あまりに当たり前のこの事実ですが、その一方、およそ Windows を除けばPerlは主要OSにははじめから組み込まれているのでそのことになかなか気がつきません。Perlがそこにあること、それは非Perlプログラマーにとってさえ空気がそこにあるがごとき前提条件となっています。

だから、Perlがそこにあることを前提にしてPerlハックにいそしみたいところですが、ちょっと待って下さい。Perlはあなた自身でビルドできますし、Perlを本格的に使いたかったらそうするべきなのです。理由は以下のとおりです。

あなたのOSがPerlを必要としている

なぜ主要OSにはPerlが付属しているのか。OSが必要としているからです。ということは、もしOS付属のPerlに何かあった場合、OSの挙動がおかしくなる可能性があるということです。実際、LWPをインストールするとMac OS Xの/usr/bin/headがHEADコマンドに置き換えられてしまうということもかつてありました。

OS付属のPerlとは独立したPerlを持てば、こうした可能性はほとんどゼロになります。

バンドル版Perlは最新とは限らない

OSのリリーススケジュールとPerlのリリーススケジュールは異なります。ですから最新のOSが、最新のPerlをバンドルしているとは限りません。例えば Mac OS X v10.6 = Snow Leopard が発売されたのは今年の9月ですが、付属しているのは Perl 5.10.0 で、最新版のPerl 5.10.1とはバージョンにずれがあります。

FreeBSDに至ってはさらに保守的で、OSの最小構成にはPerlを載せていない上に、Ports/Packageがデフォルトでインストールするのは Perl 5.8.9 です。

最新のPerlを使いたかったら、やはり自分でビルドするしかないのです。

スーパーユーザー権限がない

レンタルサーバーなどでPerlを利用する際には、上の条件に加えてさらにこの条件が加わります。最新のPerlどころかモジュールをインストールするにも支障をきたすのです。

local::libなどを使ってこの制限を乗り越える方法は確かにありますが、実は自分用のPerlをホームディレクトリにインストールしてそれを使う方が簡単だったりもします。

DIYの実際

というわけであなたは自分のPerlを持つことに決めたのですが、一体どうしたらよいのでしょう。

大まかな流れでいくと、以下のとおりとなります。

% curl -O http://www.cpan.org/src/perl-5.10.1.tar.bz2
% tar jxvf perl-5.10.1.tar.bz2
% cd perl-5.10.1
% sh Configure -des
% make
% sudo make install

最初の curl -O は Mac OS X の場合ですが、ここは fetch なり wget なり各OSの流儀にあわせてください。なんならWebブラウザーでダウンロードしても構いません。

これで自分用のPerlは出来ることは出来るのですが、自分用であっても「おしきせ」のPerlしか出来ません。自分用というからには Configure の指定をもっと細かくする必要があります。

Configure の実際

何のオプションも付けないで Configure した場合、Perlのデフォルトがそのまま使われますが、OSベンダーでさえそんなことはしていません。実際に各OSにバンドルされているPerlが、どのように Configure されているのかを確認してみることにしましょう。ちなみに確認するためには

/path/to/perl -MConfigure -le 'print $Config{config_args}'

とします。

Mac OS X v10.6.2

v5.10.0

-ds -e -Dprefix=/usr -Dccflags=-g  -pipe  -Dldflags= -Dman3ext=3pm -Duseithreads -Duseshrplib -Dinc_version_list=none -Dcc=gcc-4.2

Ubuntu 9.10

v5.10.0

-Dusethreads -Duselargefiles -Dccflags=-DDEBIAN -Dcccdlflags=-fPIC -Darchname=i486-linux-gnu -Dprefix=/usr -Dprivlib=/usr/share/perl/5.10 -Darchlib=/usr/lib/perl/5.10 -Dvendorprefix=/usr -Dvendorlib=/usr/share/perl5 -Dvendorarch=/usr/lib/perl5 -Dsiteprefix=/usr/local -Dsitelib=/usr/local/share/perl/5.10.0 -Dsitearch=/usr/local/lib/perl/5.10.0 -Dman1dir=/usr/share/man/man1 -Dman3dir=/usr/share/man/man3 -Dsiteman1dir=/usr/local/man/man1 -Dsiteman3dir=/usr/local/man/man3 -Dman1ext=1 -Dman3ext=3perl -Dpager=/usr/bin/sensible-pager -Uafs -Ud_csh -Ud_ualarm -Uusesfio -Uusenm -DDEBUGGING=-g -Doptimize=-O2 -Duseshrplib -Dlibperl=libperl.so.5.10.0 -Dd_dosuid -des

FreeBSD 8-STABLE

v5.8.9

-sde -Dprefix=/usr/local -Darchlib=/usr/local/lib/perl5/5.8.9/mach -Dprivlib=/usr/local/lib/perl5/5.8.9 -Dman3dir=/usr/local/lib/perl5/5.8.9/perl/man/man3 -Dman1dir=/usr/local/man/man1 -Dsitearch=/usr/local/lib/perl5/site_perl/5.8.9/mach -Dsitelib=/usr/local/lib/perl5/site_perl/5.8.9 -Dscriptdir=/usr/local/bin -Dsiteman3dir=/usr/local/lib/perl5/5.8.9/man/man3 -Dsiteman1dir=/usr/local/man/man1 -Ui_malloc -Ui_iconv -Uinstallusrbinperl -Dcc=cc -Duseshrplib -Dinc_version_list=none -Dccflags=-DAPPLLIB_EXP="/usr/local/lib/perl5/5.8.9/BSDPAN" -Doptimize=-O2 -pipe -fno-strict-aliasing -Ud_dosuid -Ui_gdbm -Dusethreads=n -Dusemymalloc=y -Duse64bitint

なんか目のつぶれそうなほど長いオプションをいずれも付けていますが、自分用のPerlを作るときにはこれほど長いものは必要ありません。ちなみに私が Mac OS X で日常的に使っている Perl は、以下のように Configure してあります。

% sh Configure \
　-DDEBUGGING \
　-Doptimize='-g -pipe -Os' \
　-Dusethreads \
　-Dusemultiplicity \
　-Duse64bitall \
　-Dprefix=/usr/local \
　-des

それでは、一つ一つ解説していきましょう。

-DDEBUGGING	Perl自体のデバッグ機能を有効に
-Doptimize='-g -pipe -Os'	最適化オプション。-DDEBUGGINGを指定する際には必ず-gを含めます
-Dusethreads	スレッドサポートを有効に
-Dusemultiplicity	組み込み(mod_perlなど)のサポートを有効に
-Duse64bitall	64bitフルサポートを有効に
-Dprefix=/usr/local	Perlのインストール先を/usr/localに
-des	すぐにmakeできるよう準備を整えるおまじない。ほぼどんな場合でも指定しておきます

これで"My Perl Ultimate Edition"がビルドできます。

-Dprefix

この中でも、おそらく最重要なのは -Dprefix オプションなので、少し解説しておきます。例えばここに/usrを指定した場合、

実行ファイル	/usr/bin/perl
ライブラリ	/usr/lib/perl5/5.10.1
マニュアル	/usr/share/man

といった具合にインストールされるわけですが、これを$HOMEにすれば、自分のホームディレクトリ直下にPerlをインストールすることが出来るので、スーパーユーザー権限が不要になるというわけです。もちろんその場合、OS付属のPerlより your perl が優先されるよう、$HOME/binを$PATHに加えるのは言うまでもありません。

くわしくは

INSTALL および README.os を参照してください。ここでosは各OSの名前。例えば Mac OS X なら README.macosx です。

で、明日は...誰が書くんだろ?

Dan the Contributing Perl Monger

Orochi使用例

例えば以下のよう構成のシステムがあったとします。

依存関係ダイアグラム
====================

                requires   --------------  requires
                ---------> | MyApp::Log |-----------> $file
   ---------    |          --------------
   | MyApp |----|
   --------     |          -----------------
                ---------> | MyApp::Schema | -------> @connect_info
                requires   -----------------

MyAppはLogオブジェクトとDBIx::Classスキーマに依存し、それらも$fileと@connect_infoにそれぞれ依存すると仮定します。これを実装するには以下のようなコードを書くことになります：

package MyApp;
use Moose;
use namespace::autoclean;

has log => (
    is => 'ro',
    isa => 'MyApp::Log',
    required => 1,
);

has schema => (
    is => 'ro',
    isa => 'MyApp::Schema',
    required => 1,
);

sub run {
    ....
}

__PACKAGE__->meta->make_immutable();

1;

package MyApp::Log;
use Moose;
use namespace::autoclean;

has file => (
    is => 'ro',
    isa => 'Str',
    required => 1,
);

__PACKAGE__->meta->make_immutable();

1;

package MyApp::Schema;
use Moose;
use namespace::autoclean;

extends 'DBIx::Class::Schema'

1;

このような構造を用意すると、依存関係を満たして初期化するために以下のようなコードを書く必要があります。

use MyApp;
use MyApp::Log;
use MyApp::Schema;

my $log = MyApp::Log->new(file => "/path/to/log.txt" );
my $schema = MyApp::Schema->connection('dbi:mysql:dbname=foo', 'user', 'password');
my $app = MyApp->new(
    log => $log,
    schema => $schema
);
$app->run();

この程度であれば一個一個手で書いていけば済む話ですが、依存関係が増えていくにしたがい管理するオブジェクト数とともに書かなければいけない事項があ指数関数的に増えていきます。

そうなってしまっては後から依存関係を追加・変更したりする場合に困ってしまいます。また、例えばWAF内で一旦その初期化を記したとしてもコマンドラインツールから同じオブジェクト群を作成するコードを用意しなければなりません。もちろんやってできないことはありませんが、かなり面倒くさくなってきます。

Orochiはこの作業をなるたけ1回だけ記してあとは自動的にオブジェクト群を生成できるようにするためのツールです。

Orochi の基本

Orochiは前項で紹介した仕組みの下位レイヤーを構成します。この部分は詳細を説明してもあまりおもしろくありませんのでざっくり割愛します。基本的な動作としては以下のようになります：

my $orochi = Orochi->new();

# 遅延評価でMyClass->new(\%args)を実行してオブジェクトに転換して
# 返すよう指定
$injection = $orochi->inject_constructor( $key => (
    class => 'MyClass',
    args  => \%args
) );
        
$object    = $injection->expand(); # この時点で展開
$object    = $orochi->get($key);   # 同等。$keyから$injection
                                   # オブジェクトを検索してexpand()する

# 後でそのままの値を返すよう指定
$injection = $orochi->inject_literal( $key => $value );
$value     = $injection->expand(); # $valueを返すだけ
$value     = $orochi->get($key);   # 同等

# bind_value は inject_* で指定した値をexpand()したものを遅延評価する。
# この場合、 $class->new({ arg1 => $arg1, arg2 => $arg2 }) が
# get()/expand() 時に呼ばれる
$orochi->inject_constructor(
    $key => (
        class => $class,
        args  => {
            arg1 => $orochi->bind_value( $key_for_arg1 ),
            arg2 => $orochi->bind_value( $key_for_arg2 ),
        }
    )
);

キモはinject_constructorでコンストラクタとその引数を指定して遅延評価できることと、引数そのものも同じ仕組みで遅延評価し依存関係の関係性だけを表記できることです。

MooseX::Orochi

Orochiの最終的な目的はMooseオブジェクト群を自動的にフレームワークに登録して、初期化が終わった状態でインスタンスを自動的に作成してもらう事です。Orochiに同梱されているMooseX::Orochiを使用するとMooseクラスにOrochi要のインジェクションルールを書き込んで置くことができるようになります：

package MyApp;
use Moose;
use MooseX::Orochi;
use namespace::autoclean;

# 以下の宣言は、後に
#   MyApp->new( {
#       log =>  .... # $orochi->get('myapp/log') を評価した結果
#       scuema =>  .... # $orochi->get('myapp/schema') を評価した結果
#   } );
# と評価されるよう指定しています
bind_constructor myapp => (
    args => {
        log => bind_value 'myapp/log',
        schema => bind_value 'myapp/schema',
    }
);

sub run { ... }

__PACKAGE__->meta->make_immutable();

1;

このように "use Moosex::Orochi" とすることにより、現在のスコープで "bind_constructor" と "bind_value" というDSL／関数が使用可能になります。

bind_constructorは前項のinject_constructorと同じように特定のキーと現在定義中のクラスのインスタンスを結びつけます。

package MyClass;
bind_constructor $key => ( %params );

この定義をすることによって、後に以下のようにインスタンスを取得したい旨を宣言しているわけです：

my $obj = $orochi->get($key)

なお、%paramsにクラスを指定する必要はありませんので、arg1とarg2が必要なMooseオブジェクトを定義するには

package MyClass;
use Moose;
sue MooseX::Orochi;
use namespace::autoclean;

bind_constructor 'myclass' => (
    args => {
        arg1 => bind_value 'myclass/arg1',
        arg2 => bind_value 'myclass/arg2'
    }
);

というようにすれば、OrochiはMyClassの引数の設定をしてくれます。もちろんmyclass/arg1とmyclass/arg2は別途注入する必要があります。

他のクラスも同じ仕組みを使って設定を記入していきます：

package MyApp::Log;
use Moose;
use MooseX::Orochi;
use namespace::autoclean;

bind_constructor 'myapp/log' => (
    args => {
        file => bind_value 'myapp/log/file'
    }
);

__PACKAGE__->meta->make_immutable();

1;

package MyApp::Schema;
use Moose;
use MooseX::Orochi;
use namespace::autoclean;

extends 'DBIx::Class::Schema';

bind_constructor 'myapp/schema' => (
    args => bind_value 'myapp/schema/connect_info',
    deref_args => 1,
);

__PACKAGE__->meta->make_immutable();

1;

これができたところで、inject_class() メソッドを使って、クラスの中に保存された設定をOrochiインスタンスに注入すれば、あとはget() で作成されたインスタンスを取得するだけです：

use Orochi;

my $o = Orochi->new();

# クラス定義から依存関係等を注入
$o->inject_class('MyApp');
$o->inject_class('MyApp::Log');
$o->inject_class('MyApp::Schema');

# このあたりは設定ファイルから読み込むのが吉
$o->inject_literal(
    'myapp/schema/connect_info' => 
        [ 'dbi:mysql:dbname=foo', 'username', 'password' ],
);
$o->inject_literal(
    'myapp/log/file' => '/path/to/log.txt',
);

my $app = $o->get('myapp');
$app->run();

なお、ここまでの説明はMooseX::OrochiのPODにも書いてありますのでそちらもあわせて参照してください。

MooseX::Orochiの継承

一度特定のクラスにMooseX::Orochiの設定を施せばその子クラスも同じ設定を引き継ぐ事ができます。

package Parent;
use Moose;
use MooseX::Orochi;
use namespace::autoclean;

bind_constructor 'myapp' => (
    args => {
        arg1 => bind_value 'myapp/arg1',
        arg2 => bind_value 'myapp/arg2',
    }
);

package Child;
use Moose;
use namespace::autoclean;

extends 'Parent';

use Orochi;

my $orochi = Orochi->new();
$orochi->inject_literal('myapp/arg1' => 'value1');
$orochi->inject_literal('myapp/arg2' => 'value2');
$orochi->inject_class('Child');

my $child = $orochi->get('myapp');

このようにすることでMooseX::Orochiの設定を引き継ぐ事ができるのでオブジェクトの使い回しも簡単にできます。子クラスでbind_constructorを使用すれば子クラス特有の設定でオーバーライドすることも可能です。

CatalystでOrochiを使う

Catalystは元からある程度の自動初期化機能を搭載していますが、それはあくまでCatalystというコンテキスト内であって、それ以外のコンテキストでは同様の仕組みは使えません。なので私はいわゆるアプリケーションロジック部分をCatalystから切り離し、Orochiを通して オブジェクト群を作成しています。

この仕組みをCatalyst内で簡単に扱うために Catalyst::Model::Orochi(http://search.cpan.org/dist/Catalyst-Model-Orochi) もCPANに登録されており、Orochiを設定ファイルからコントロールすることができます。

package MyApp::Model::Orochi;
use Moose;
use namespace::autoclean;

extends 'Catalyst::Model::Orochi';

__PACKAGE__->meta->make_immutable();

1;

使用する際には model() 関数からOrochiインスタンスにアクセスすることができます：

package MyApp::Controller::Root;
use Moose;
use namespace::autoclean;
BEGIN { extends 'Catalyst::Controller' }

sub hoge :Local {
    my ($self, $c) = @_;

    my $thing = $c->model('Orochi')->get('whatever');
}

__PACKAGE__->meta->make_immutable();

1;

このようなモデルを設定しておき、必要なオブジェクト群にMooseX::Orochiを適用するだけであとは基本的にmyapp.yaml内に記述を追加するだけで様々な値を注入することができます：

Model::Orochi:
  injections:
    key1: value1  # リテラル値を注入
    key2: value2
    key3: value3
  classes:
    - Class1      # 明示的に指定されたクラスを注入
    - Class2
    - Class3
  namespaces:
    - MyApp::API  # MyApp::API 内の全てのMooseX::Orochiクラスの
                  # 定義を注入

この仕組みを使うと、1行も初期化コードを書かずにオブジェクト群を生成することができます

まとめ

本稿の最初に書いた通り、もうオブジェクト群を初期化するのにとんと嫌気がさしていたのでこの仕組みは実際にプロダクション環境で使い始めています。以下の注意点等が問題にならないようであれば、是非一度さわってみてください！

• 使いどころ
  • お互い依存関係のあるオブジェクト群が比較的多くある
  • Catalyst（もしくはその他のWAF)の中だけでなく、違うコンテキスト（例：コマンドラインツール）などでも同じオブジェクト群の初期化が発生する
  • 正直初期化コードをもう書きたくない人向け

• 注意点
  • DIは全てのアプリケーションで必要なわけではないので、（人的、リソース的）コストとのバランスを考えて導入したほうがいい
  • Mooseを使わないなら、Orochiも使わない
  • Orochiは再帰的な依存関係の自動解決しません。その場合はOrochi::Injection::Setterを使います
  • MooseX::Orochiを使うと基本的に1クラス＝1インスタンスになります。複数必要な場合は違う方法で指定する必要があります

明日は・・・うほ！dankogaiさんです！

本題

正確にいうと、「作った」のではなく、mod_cidr_lookupというApacheモジュールを「ポーティング」しました。

• mod_cidr_lookup

Net::IP::Match::* 系のCPANモジュールには、様々なデータ構造、探索方法の実装があるのですが、今回のお題の「Net::IP::Match::Trie」は、その名に冠しているようにTrie(トライ木)というデータ構造を採用しています。

Trieについての解説は、

• http://ja.wikipedia.org/wiki/Trie , http://en.wikipedia.org/wiki/Trie
• http://dsas.blog.klab.org/archives/51294589.html

などを参照していただくとして、ここでは、他の Net::IP::Match::* 系の実装と比べて、Net::IP::Match::Trieがどのような特徴を持っているか書いてみたいと思います。

まずはベンチマーク

kazeburoさんの記事のベンチマークスクリプトをベースにして、ベンチマークをとってみました。(ベンチマークスクリプトは、 http://github.com/hirose31/p5-net-ip-match-trie/blob/master/samples/benchmark/benchmark.pl にあります)

ベンチマークスクリプトの変更点は以下の通りです。

• Net::IP::Match::Trieを追加
• Net::IP::Match::XS2を追加
• 検査の母データとなるCIDRを155個に増量

Net::IP::Match::Trie は XS 版と Pure Perl 版があるので、それぞれでベンチマークをとりました。結果はこうなりました:

$ ./samples/benchmark/benchmark.pl
155
Net::IP::Match::Trie::XS
            (warning: too few iterations for a reliable count)
              Rate     cidr  regexp patricia       xs      bin      xs2     trie
cidr       44643/s       --    -67%     -71%     -77%     -92%     -93%     -97%
regexp    134529/s     201%      --     -11%     -31%     -77%     -78%     -90%
patricia  151515/s     239%     13%       --     -22%     -74%     -76%     -88%
xs        194805/s     336%     45%      29%       --     -66%     -69%     -85%
bin       576923/s    1192%    329%     281%     196%       --      -8%     -56%
xs2       625000/s    1300%    365%     312%     221%       8%       --     -52%
trie     1304348/s    2822%    870%     761%     570%     126%     109%       --

$ env NIMT_PP=1 ./samples/benchmark/benchmark.pl
155
Net::IP::Match::Trie::PP
             Rate     cidr   regexp patricia       xs     trie      bin      xs2
cidr      40323/s       --     -69%     -74%     -80%     -82%     -93%     -93%
regexp   128205/s     218%       --     -16%     -36%     -42%     -79%     -79%
patricia 152284/s     278%      19%       --     -24%     -31%     -75%     -75%
xs       201342/s     399%      57%      32%       --      -9%     -66%     -66%
trie     220588/s     447%      72%      45%      10%       --     -63%     -63%
bin      600000/s    1388%     368%     294%     198%     172%       --      -0%
xs2      600000/s    1388%     368%     294%     198%     172%       0%       --

XS版はダントツで最速、Pure Perl版もPure Perlな実装の間では最速という結果がでました。

入力CIDR数と、セットアップとマッチ処理時間の関係

さて、「最速」というのはわかったのですが、Net::IP::Match::Trieがどのような「特徴」をもっているかというのはこれだけではわかりません。ですので、もうひとつ、ベンチマークスクリプトを走らせてみたいと思います。

ベンチマークには、Net::IP::Match::Regexp に含まれる speedtest.pl を改変したものを使いました。(スクリプトは、 http://github.com/hirose31/p5-net-ip-match-trie/blob/master/samples/benchmark/speedtest.pl にあります)

結果はこうなりました。("Networks:"は、探索母データとなるCIDRの数です)

$ ./samples/benchmark/speedtest.pl
Initialization time of test: 0.032882

Networks: 1, IPs: 10000
Test name              | Setup time | Run time | Total time | Errors
-----------------------+------------+----------+------------+--------
simple                 |    0.000   |  0.058   |    0.058   | n/a
Net::IP::Match::XS     |    0.000   |  0.015   |    0.016   | 0
Net::IP::Match::Regexp |    0.001   |  0.072   |    0.072   | 0
Net::IP::Match::Trie   |    0.000   |  0.022   |    0.022   | 0

Networks: 10, IPs: 10000
Test name              | Setup time | Run time | Total time | Errors
-----------------------+------------+----------+------------+--------
simple                 |    0.000   |  0.085   |    0.085   | n/a
Net::IP::Match::XS     |    0.000   |  0.022   |    0.022   | 0
Net::IP::Match::Regexp |    0.001   |  0.091   |    0.093   | 0
Net::IP::Match::Trie   |    0.000   |  0.023   |    0.023   | 0

Networks: 100, IPs: 10000
Test name              | Setup time | Run time | Total time | Errors
-----------------------+------------+----------+------------+--------
simple                 |    0.000   |  0.371   |    0.371   | n/a
Net::IP::Match::XS     |    0.000   |  0.084   |    0.084   | 0
Net::IP::Match::Regexp |    0.010   |  0.098   |    0.107   | 0
Net::IP::Match::Trie   |    0.001   |  0.022   |    0.024   | 0

Networks: 1000, IPs: 10000
Test name              | Setup time | Run time | Total time | Errors
-----------------------+------------+----------+------------+--------
simple                 |    0.002   |  2.784   |    2.786   | n/a
Net::IP::Match::XS     |    0.001   |  0.647   |    0.648   | 0
Net::IP::Match::Regexp |    0.090   |  0.103   |    0.193   | 0
Net::IP::Match::Trie   |    0.064   |  0.023   |    0.087   | 4

この結果から読み取れることはこんなところでしょうか:

• Net::IP::Match::XS
  • API的に、セットアップ処理がなくマッチ処理のみの実装になっている
  • マッチ処理はそれほど高速ではない
• Net::IP::Match::Regexp
  • 入力CIDR数の増加によりセットアップ時間が線形に増加するので、少ないうちはいいが多くなると注意
  • マッチ処理に要する時間も徐々に増加した
• Net::IP::Match::Trie
  • 入力CIDR数の増加によりセットアップ時間も増加する
  • 一方、Trieの特長により、マッチ処理時間はまったく変わらない (CIDR数が増加しても一定)

ちなみに、最後の結果で Net::IP::Match::Trie の Errors の項が非ゼロですが、これは、Net::IP::Match::Trie はマッチするCIDRが複数ある場合には、ネットワークアドレスが一番長い(=ネットマスクが一番短い)ものを返す実装になっているのに対し、ほかのものはそういう実装になっていないからです。

たとえば、

$matcher->add("big"   => [qw(10.0.0.0/8)]);
$matcher->add("small" => [qw(10.6.25.0/24)]);
say $matcher->match_ip("10.6.25.1");

の結果は、最初に add した "big" ではなく、より限定的(ネットワークアドレスが長い=ネットマスクが短い)なCIDRである "small" になります。

まとめ

• Net::IP::Match::Trieは、
  • 一度だけ、かならずセットアップ処理が必要です
  • マッチ処理は最速です (少なくとも今回比較した中では)
  • また、Trieの特長により、探索母データのCIDRの数がとっても多くなっても、常に一定の速度で結果を返せます
  • 一回のマッチ処理で、ラベル付けしたいずれかのCIDRにマッチするかどうかがチェックできます
    • 例: 「このIPアドレスは、どの携帯電話キャリア(DoCoMo、au、Softbank、willcom)のものか？」というのが、Net::IP::Match::XSやNet::IP::Match::Regexpではキャリアの数の分だけマッチ処理が必要ですが、Net::IP::Match::Trieなら一発でわかります。
• よって、Net::IP::Match::Trie は、このような用途に向いています:
  • そのライフサイクルの中で、初期セットアップの回数より、マッチ処理の回数の回数が圧倒的に多い
  • CIDRの変化が頻繁にはない
    • 例: daemon的な比較的長寿のサーバプロセスとか

• 最後に。Advent Calendarのおかげで、Net::IP::Match::Trie というモジュールを作るきっかけを得ることができました！ ありがとうございました！ Happy SUSHI!!!

というわけで今日はここまでです。明日は lestrrat さんです。

本題

Qudoは既存のジョブキューシステムを使ってみて思ったいくつかの要望を

実現する目的で作成しました。ポイントは拡張性と使いやすさです。

まずは、簡単な例から初めてみましょう。

Advent Calendarということで、クリスマスにプレゼントを願う子供と

それを届けるサンタクロースを再現してみたいと思います。

QudoはデータストアにRDBMSを用いています。

そのため、使用する際にはあらかじめDBを作成する必要があります。

現在MySQL,SQLite,PostgreSQL（多分）に対応しています。

各DB用のスキーマファイルは「http://github.com/nekokak/qudo/tree/master/doc/」

にありますので、そちらを参照してDBを作成してください。

以下の内容はMySQLを用いた場合を前提として記載しています。

先に、子供がサンタクロースにプレゼントを注文します。( ClientがJobを投入します )

children.pl

#!/usr/bin/perl 
use strict;
use warnings;

use Qudo;
use MyApp::Worker::Santa;

my $qudo = Qudo->new(
    driver_class => 'Skinny',
    databases => [+{
        dsn      => 'dbi:mysql:qudo',
        username => 'root',
        password => '',
    }],
);

for my $present ( qw/ cake chocolate / ){
        $qudo->enqueue("MyApp::Worker::Santa", { arg => $present });
}

そして、サンタクロースが子供達からのプレゼントを届けます(Jobを処理するWoekerを作ります)

package MyApp::Worker::Santa;

use strict;
use warnings;
use base qw/Qudo::Worker/;

sub work {
    my ($self , $job ) = @_;

    my $present = $job->arg();
    print "Hello , I give you present which you hoped.It is $present.\n";

    $job->completed();
}
1;

最後に、クリスマス当日を迎えてサンタクロースに届けてもらいましょう(workerを実際に起動します)

cometrue.pl

#!/usr/bin/perl 
use strict;
use warnings;

use Qudo;
my $qudo = Qudo->new(
    driver_class => 'Skinny',
    databases => [+{
        dsn      => 'dbi:mysql:qudo',
        username => 'root',
        password => '',
    }],
    manager_abilities => [qw/MyApp::Worker::Santa/],
);

$qudo->work;

cometrue.plを実行した結果、以下のように表示されれば成功です。

(workerはwhileのループで動き続けるので、Ctrl-Cで抜けてください)

Hello , I give you present which you hoped.It is chocolate.
Hello , I give you present which you hoped.It is cake.

と、ここまでが最も簡単な例です。ここから少し応用していきましょう。

応用その1:Enqueueする情報を複雑化させる

まずは、この状態だとサンタは相手を選ばずに適当にプレゼントを

バラまいているので、それぞれの子供に希望の物が届くようにしてあげましょう。

children.plを以下のように変更します。

< for my $present ( qw/ cake chocolate / ){
<     $qudo->enqueue("MyApp::Worker::Santa", { arg => $present });
---
> my @children = (
>     {
>         name    => 'masartz',
>         present => 'cake',
>     },
>     {
>         name    => 'nekokak',
>         present => 'chocolate',
>     },
> );
> 
> $qudo->manager->global_register_hooks(qw/Qudo::Hook::Serialize::JSON/);
> 
> for my $child ( @children ){
>     $qudo->enqueue("MyApp::Worker::Santa2", { arg => $child });

プレゼント名をScalarで渡していたところを、

子供の名前とプレゼントをペアにしたHashRefにしました。

このために、QudoのHook機能を使って、Job をenqueueする時に

引数をシリアライズします。今回はJSONを用いました。

これはオプション扱いですが、Qudoのパッケージに含まれています。

合わせて、Worker側も手を加えます。

<     my $present = $job->arg();
<     print "Hello , I give you present which you hoped.It is $present.\n";
---
>     my $child = $job->arg();
>     print "Hello , $child->{name}. I give you present which you hoped.It is $child->{present}.\n\n";

こちらは、単純に$job->argで取れてくるものをHashRefで

来るように想定して変更しただけです。

さらに、実行するcometrue.plにもHookを使うのを明示化する一文を追加する必要があります。

workメソッドを実行する直前に以下の1行を追加してください。

  manager_abilities => [qw/MyApp::Worker::Santa2 /],
  );
  
+ $qudo->manager->global_register_hooks(qw/Qudo::Hook::Serialize::JSON/);
  $qudo->work;

そして、これで実行してみます。

Hello , nekokak. I give you present which you hoped.It is chocolate.
Hello , masartz. I give you present which you hoped.It is cake.

各Jobで名前とプレゼントの情報を正しく受け取り、実行出来た事がわかります。

子供達がそれぞれ望んだプレゼントを受け取れるようになりました。

ただプレゼントするだけなのも無愛想ですし、せっかくなのでサンタクロースに

お決まりの決め台詞を必ず言ってもらうようにしましょう。

応用その2:Pluginを作ってみる

この実現のために、Plugin機構を使います。

Qudoには様々な場所に独自のPluginを追加出来るようになっています。

先にPluginの中身を作成します。

package MyApp::Worker::Plugin::PreMessage;
use strict;
use warnings;
use base 'Qudo::Plugin';

sub plugin_name{ 'pre_message' }

sub load {
    my $class = shift;

    $class->register(
        sub {
            print "Merry Christmas!! \n";
        }
    );
}
1;

とてもシンプルですが、このメッセージをプレゼントを渡す前に必ず

言ってもらうようにWorkerを修正します。

MyApp::Woker::Santa のprint文の前に以下の1文を追加してください。

  my ($self , $job ) = @_;

+ $job->manager->plugin->{pre_message}->();

  my $child = $job->arg();

最後に忘れずにcometrue.plも修正します。先ほどのHookの時と同じように

wokメソッドより前に以下の1文を追加してください。

  manager_abilities => [qw/MyApp::Worker::Santa2 /],
  );
  
+ $qudo->manager->register_plugins(qw/MyApp::Worker::Plugin::PreMessage/);
  $qudo->manager->global_register_hooks(qw/Qudo::Hook::Serialize::JSON/);
  $qudo->work;

さぁ、これで実行すると以下のようになるハズです。

Merry Christmas!! 
Hello , nekokak. I give you present which you hoped.It is chocolate.
Merry Christmas!! 
Hello , masartz. I give you present which you hoped.It is cake.

成功したでしょうか？

最終形をgistにあげておきました。

children.pl : http://gist.github.com/254925

MyApp::Wokrer::Santa : http://gist.github.com/254928

cometrue.pl : http://gist.github.com/254932

まとめ

Qudoの機能について簡単ではありますが説明させていただきましたが、

いかがでしたでしょうか？

Qudoの開発状況としては、

・CPANにはDevelopper Versionで登録していましたが、つい最近正式版を公開しました

-> http://search.cpan.org/~nekokak/Qudo-0.02

・とはいえ、いくつかTodoも残っているのでgithubで開発は継続中です

-> http://github.com/nekokak/qudo

・質問やご要望等ある方がいらっしゃいましたら、

#qudo@irc.perl.org までお気軽にお越し下さい

という感じです。

今回紹介したような拡張性・使いやすさを念頭においていますので、

使ってみたら感想などいただけると大変参考になります。

あと足りない部分の開発フォローしていただくのも歓迎です。

というわけで今日はここまでです。明日はid:hirose31 さんです。

本題

さて、perlのプログラムのデバッグするなら、perl -d というのも良いですが、print デバッグもお手軽でいいですよね。

しかし、怪しい変数を追いかけたり、見知らぬオブジェクトの中を調べたりするのに、いちいち print や warn を挿入していくのも面倒です。

そんな時には、Tie::Trace が役に立つかもしれません。

単純な例

次の $hoge、 @hoge、 %hoge の各変数を追いかけてみます。

use Tie::Trace qw/watch/;

watch my $hoge;
watch my @hoge;
watch my %hoge;

$hoge = 1;

push @hoge, "a";
delete $hoge[-1];

$hoge{1} = 1;
$hoge{"abc"} = "xyz";

以下のようなメッセージが表示されます。

main:: $hoge => 1 at sample1.pl line 7.
main:: @hoge => PUSH('a') at sample1.pl line 9.
main:: @hoge[0] => DELETED('a') at sample1.pl line 10.
main:: %hoge => {1} => 1 at sample1.pl line 12.
main:: %hoge => {abc} => 'xyz' at sample1.pl line 13.

若干分かりにくい表示ですが、main:: 変数名 は、main package で宣言されている変数という意味です。=> の後ろに、代入されたり削除された値が入ります。PUSH や DELETED のように何かしら説明っぽいものが入る場合もあります。

リカーシブに追跡

watch 関数で監視された変数に、ハッシュリファレンスやアレイリファレンスが代入された場合、それらは再帰的にチェックされ、監視する対象になります。

use Tie::Trace qw/watch/;

watch my @array;
push @array, { a => 1 }, [0, 1, 2, [10, 20, 30, { a => 'b'}]];
$array[0]->{b} = 2;
$array[1]->[3]->[3]->{a} = "c";
$array[1]->[3]->[3]->{c} = "d";

としてみます。

main:: @array => PUSH({'a' => 1},[0,1,2,[10,20,30,{'a' => 'b'}]])
 at sample2.pl line 4.
main:: @array => [0]{b} => 2 at sample2.pl line 5.
main:: @array => [1][3][3]{a} => 'c' at sample2.pl line 6.
main:: @array => [1][3][3]{c} => 'd' at sample2.pl line 7.

このように、@arrayに挿入された無名ハッシュや無名配列に値が入ってもメッセージが表示されます。ただし、オブジェクトや tie されたリファレンスなどが入ってきた場合、それらは監視対象にはなりませんので、ご注意ください。

オブジェクトの中身をチェックする

オブジェクトの中身にをチェックするのにも使えます。Mouse(0.40)でやってみました。

package Hoge;

use Mouse;
has "name" => (is =>"rw");
has "height" => (is =>"rw");

package main;

use Tie::Trace qw/watch/;

my $x = Hoge->new;

watch %$x;

$x->name("ktat");
$x->height(173)

以下のような表示がされます。

{name} => 'ktat' at accessor for name (.../Mouse/Meta/Method/Accessor.pm) line 2.
{height} => 173 at accessor for age (.../Mouse/Meta/Method/Accessor.pm) line 2.

package名や変数名が取れていないときは、グローバル変数、無名リファレンスなんかです。

ちなみに、Moose(0.92)だとこんな感じでした。

{name} => 'ktat' at accessor name defined at sample4.pl line 6.
{height} => 173 at accessor height defined at sample4.pl line 7.

にしても、Mouse も Moose もメッセージが独特な感じですね。Mouseの "line 2" がよくわかりませんが、追ってません。

しかし、いずれも代入された箇所がわかりませんね。以下のように、caller オプションを与えてみましょう。

watch %$x, caller => [0, 1];

watch の変数名の後の引数はオプションになります。callerオプションをつけると、指定された分だけたどってくれます。

{name} => 'ktat' at accessor name defined at sample5.pl line 6.
 at sample5.pl line 15.
{height} => 173 at accessor height defined at sample5.pl line 7.
 at sample5.pl line 16.

これで、代入場所が特定できましたね。

リカーシブなチェックをやめる

リカーシブなチェックはいらないという場合もあるでしょう。そういうときは次のようにします。

watch %var, r => 0;

これで、リファレンスが代入されても、それらは監視対象にはなりません。

条件に一致するキーのみ

use Tie::Trace qw/watch/;

watch my %foo, key => ['foo'];
watch my %bar, key => [qr/bar/];
watch my %buz, key => [sub{my($self,$key) = @_;$key =~/buzbuz/}];
watch my %foobarbuz,
  key => ['foo', qr/bar/,
          sub {my ($self, $key) = @_; return $key =~/buzbuz/}];

$foo{foo} = 1;
$foo{hoge} => {foo => 2};
$foo{hoge}->{foo} = 2;

$bar{bar} = 1;
$bar{beer} = 2;
$bar{barbarbar} = 3;

$buz{buz} = 1;
$buz{buzbuz} = 1;

@foobarbuz{qw/foo barbar buzbuz BUZ Buzbuz/} = ('a' .. 'e');

結果は以下のように、key が条件に合致するものしか出力されません。

main:: %foo => {foo} => 1 at sample5.pl line 10.
main:: %foo => {hoge}{foo} => 2 at sample5.pl line 12.
main:: %bar => {bar} => 1 at sample5.pl line 14.
main:: %bar => {barbarbar} => 3 at sample5.pl line 16.
main:: %buz => {buzbuz} => 1 at sample5.pl line 19.
main:: %foobarbuz => {foo} => 'a' at sample5.pl line 21.
main:: %foobarbuz => {barbar} => 'b' at sample5.pl line 21.
main:: %foobarbuz => {buzbuz} => 'c' at sample5.pl line 21.

同じ要領で、key を value に変えると、value に対する条件を指定できます。

メッセージを変更する

表示するメッセージを変えたいこともあるでしょう。例えば、キー 'foo' が入ってきたときの、キー 'var' の値が知りたいとか。

use Tie::Trace qw/watch/;

watch my %foo,
  key => ['foo'],
  debug => sub {my ($self, $v) = @_;
                if (%{$self->storage}) {
                  return $v . " {var} is " . $self->storage->{var}
                } else {
                  return $v;
                }
	      };

%foo = (foo => 1, var => 2);
$foo{foo} = 2;
$foo{var} = 3;
$foo{foo} = 4;

'foo' が代入された行数でのみ、メッセージが出ています。

main:: %foo => {foo} => 1 at sample7.pl line 13.
main:: %foo => {foo} => 2 {var} is 2 at sample7.pl line 14.
main:: %foo => {foo} => 4 {var} is 3 at sample7.pl line 16.

キー 'bar' が入ってきたときの、親のハッシュリファレンスのキー 'xxx' の値が知りたいとか。

use Tie::Trace qw/watch/;

my %parent = (child => {foo => 10, bar => 100}, xxx => "xxx");

watch %parent,
  key => ['bar'],
  debug => sub {
             my ($self, $v) = @_;
             if (my $p = $self->parent) {
               return "$v; parent->{xxx} is ". $p->storage->{xxx};
             } else {
               return $v;
             }
           };

$parent{child}->{bar} = 1;
$parent{xxx} = 10;
$parent{child}->{bar} = 1000;

以下のようなメッセージとなります。

main:: %parent => {child}{bar} => 1; parent->{xxx} is xxx at sample8.pl line 15.
main:: %parent => {child}{bar} => 1000; parent->{xxx} is 10 at sample8.pl line 17.

ここで使われている、storage メソッドは、実際のデータが入っているリファレンスを返し、parent メソッドは親のオブジェクトを返します。

注意事項

たいていのケースで特に問題なく動くとは思いますが、変数を変質させてますので、何か変なことが起きるかもしれません。そういうときは、素直に perl -d でもしてくださいませ。

まとめ

今回は、Tie::Trace を使った、お手軽な print デバッグについて解説しました。

一応日本語のドキュメントも用意してありますので、よろしければ、そちらもどうぞ。

というわけで今回はここまで。明日は id:masartz さんです。

■HTML::Featureで本文抽出

まずは分析する対象のデータを持ってくるところからなんですが、そこの所は割愛してコンテンツを持ってきたところから話をします。

持ってきたHTMLデータにはヘッダやらフッタやらサイドメニューやら、おおよそ本文とは関係ない部分がたっぷり含まれていますよね。

これらのノイズをどうにかして除去したい。逆に言うと本文だけを効率よく抽出したい、と考えるわけです。

そこでHTML::Featureというモジュールをつくりました。

事前の定義とか一切なしで、おおよそいい感じで本文部分を推測して抽出してくれます。

使い方はこう。

use HTML::Feature;
my $f = HTML::Feature->new(
    engines => [
        'HTML::Feature::Engine::LDRFullFeed',
        'HTML::Feature::Engine::GoogleADSection',
        'HTML::Feature::Engine::TagStructure',
    ]
);
print $f->parse($url)->text;

engines のところにごちゃごちゃ書いてますが、これは抽出ロジックのエンジン達です。ここに複数の抽出ロジックを並べておくと、うまく抽出できるまで上から順に試していきます。

エンジンは以下の3つを用意しています。

• LDRFullFeed
  • WedataのLDRFullFeedデータを使ってXPathで本文箇所をピックアップします。なのでマッチするURLであればとても正確。
• GoogleADSection
  • Google ADSenceを導入している場合はタグで囲まれてる部分を正規表現で抜きます。なのでこれもタグがあれば正確。
• TagStructure
  • HTMLタグの構成を解析して各DOMノードをスコアリングし重要そうな場所を推測。明確に本文があれば結構正確だけど、リンクリストや記事がないようなサイトは苦手。

さて、いまここで「特定サイトのコンテンツだけは、手動で定義してでも正確に本文抽出したい」というような要望があったとします。その場合には独自のエンジンを記述することも可能です。

独自エンジンをengines の先頭に配置すれば、「 独自エンジン > LDRFullFeed > GoogleADSection > Tagstructure 」の優先順位で処理が進みます。

ちなみにenginesに何も指定しなければTagStructureがデフォルトエンジンとして動きます。

まずはこんな感じで本文と思わしきところだけを適当に引っこ抜いておきます。楽チンですね！

　参考）

　　http://d.hatena.ne.jp/download_takeshi/20090728/1248813497

■特徴語の抽出 (Lingua::JA::TFIDF, Lingua::JA::OkapiBM25)

さて本文だけをスッポリ抽出できたら、次は本文の中からさらに「特徴的な単語」を抽出していきます。

情報検索の世界では特徴語抽出は「いろはのいの字」的なものです。それに関しては古くから「TF/IDF」というアルゴリズムが王道中の王道とされてきました。

ところが、いざ真面目に取り組もうとすると、仕込みというか事前準備がそれなりに必要となってしまい、「気軽に試してみる」というにはちょいと面倒な処理でした。

そこで「精度はちょっとテキトーでもいいから手軽にやってみたいよー」というラテン系な人のためにLingua::JA::TFIDFというモジュールを作りました。

なんの前準備もいらないので手軽です。内部的にかなり大胆な(テキトーな）計算をしてるんですが、その割にまあまあの精度がでます。

use Lingua::JA::TFIDF;

my $calc   = Lingua::JA::TFIDF->new;
my $result = $calc->tfidf($text);

# 特徴語とスコアのハッシュをスコアの高い順に上位10件表示
print Dumper $result->list(10);

最近ではTF/IDFのかわりに「BM25」というアルゴリズムも使われるようです。TF/IDFの改良版みたいなものですね。

こっちについてはつい数日前にモジュール化してみました。

Lingua::JA::OkapiBM25です。

使い方はLingua::JA::TFIDFとほぼ同じなのでコードは割愛しますが、試してみるとTF/IDFよりもややバランスがいいかな、といった結果が得られました。

　参考）

　　http://d.hatena.ne.jp/download_takeshi/20081031/1225463411

　　http://d.hatena.ne.jp/download_takeshi/20091206/1260130230

■Lingua::JA::Categorizeで文書分類してみる

いよいよ大詰めです。

ドキュメントから特徴語を抽出できるようになったら、あとは大量にデータをさばいていきましょう！

先ほどのLingua::JA::TFIDFなどでのアウトプットとして { URL => { 特徴語 => スコア, 特徴語 => スコア, ... }, ... } なデータが大量に蓄積できました。

これらのデータを使ってなにか面白いことができそうな気がしますよね！？

それではLingua::JA::Categorizeを使ってベイジアンによる文書分類器でもつくってみましょう。

Lingua::JA::Categorize は「お好みのカテゴリ構成の分類器をスピーディーに作るため」に書いたモジュールというかフレームワークのようなものです。

作り方は超簡単。モジュールをインストールして、適当なカテゴリ一覧をYAMLで書いて、あとはgenerate()と唱えてください。

トイレに行ってコーヒーでも飲んでいる間に分類器が出来上がってるはずです！

use Lingua::JA::Categorize;
my $c = Lingua::JA::Categorize->new;
$c->generate($category_config);
$c->save('save_file_name');

分類器を使うときはこう書きます。

use Lingua::JA::Categorize;
my $c = Lingua::JA::Categorize->new;
my $result = $c->categorize($text);
print Dumper $result->score; # 分類結果（1位から3位）

らくらくですね♪

　（参考）

　　http://d.hatena.ne.jp/download_takeshi/20081124/1227539934

■クラスタリングをガンガンこなす（Text::Bayon）

さきほどの文書分類器は事前にカテゴリを定義して、それに即して自動的に文書を分類するものでした。

ですが実際にカテゴリリストを自分で定義しようとすると「世の中にはどんな分野のテーマがどれくらいあるかなんてわからないよ～、適切なカテゴリなんて決められないよ～」という事態にすぐに陥るわけです。

そこでちょっと視点をかえて、K-means法などを使って与えられたデータを自然なカタチにクラスタリング処理して、その上で各クラスタの重心にあつまってるデータを目視して、実際のカテゴリを検討する、みたいなことをしたくなるはずです。

そこでText::Bayonの登場です！ (昨日書いたばかりのできたてホヤホヤだよ!)

「Bayon」というのは非常に優秀な軽量クラスタリングツールでして、Mixiのfujisawaさんという方が開発＆公開されています。

Text::Bayon はこの便利なBayonをperlからシームレスに利用するためのハンドリングモジュールです。これを使えばperlから透過的にBayonを使えるようになります。

use strict;
use Text::Bayon;

my $bayon = Text::Bayon->new;

# 架空のデータ生成関数
# { ドキュメントID => { 単語 => スコア, ... }, ... }　なデータ構造を生成
my $input = _gene_data(); 

# Bayonに渡す任意のオプション
my %options = (
    number => 10,
    point  => 1,
    idf    => 1,
);

# クラスタリング！
my $output = $bayon->clustering($input_data, \%options);

print Dumper $output;
# 結果データはこんな構造
# { クラスタ => [ ドキュメントID, ドキュメントID, ... ], ... }

スムーズですね！そもそも便利なBayonですが、もっと便利に使えるようになりました。

■まとめ

こんな感じで、他にもいろいろなモジュールを使ったり、作ったりしながら、毎日毎日、飽きもせずデータマイニング的なことをしております。

今度どこかで「オレもPerlでマイニングしてるゼ」という人たちで集まってみたいものですね！

明日は id:ktatさんです。お楽しみに～。