[Perl]evalの中で起こったエラーを検出する

この前、実稼働中のかなり古いコードの不具合対応ということで、そのコードをチェックしていたのですが、その中で

my $dbh = DBI->connect(...);
eval {  
    my $sth = $dbh->prepare(...);
    $sth->execute;
    $sth->finish;
};

みたいな箇所(上のコードは実物じゃないですよ)があったんですね。で、evalで被ってやるのはまあ100歩譲って「仕方ないなあ」で済ませましたけど、よりによって、$@に入ってきた値をキャッチするロジックがなかったんです。
当然エラーとかが起こってもエラーログすら吐かず、何食わぬ顔で突っ走ってしまう。そんなわけで、SQL周りの不具合を見つけるのに数時間を要してしまったわけです。

その場ですぐに修正パッチを作成・適用して事なきを得ましたが、僕は心の奥底で思いました。「evalの中でエラーが起こったら、無理やりにでもエラーログにその内容を吐かせたい！」と。

で、調べてみたら、$SIG{__DIE__}にコードリファレンスを食わせることで、その願いは叶えられるとのことでした。
これを使って、ついでにエラー発生時刻も併せて吐いてやれば、後の不具合調査時に役立つでしょう。

というわけで、試しにコードを書いてみました。

use warnings;
use strict;
use Time::Zone;
use DateTime;
use DBI;

$SIG{__DIE__} = sub {
    my $now = DateTime->from_epoch( epoch => time() + tz_local_offset() )->strftime( '%Y/%m/%d %H:%M:%S' );
    warn join( " - ", $now, "CRITICAL", shift );
};

### DBD::sqrightなんてないので、このコードはエラーとなる。
eval {
    my $dbh = DBI->connect( 'dbi:sqright:hoge.txt' );
};

END {
    print "FINISHED!!!\n";
}

この動作結果は、以下の様になります。

2011/01/27 15:19:20 - CRITICAL - Can't locate DBD/sqright.pm in @INC (@INC contains: /home/yt/perl5/perlbrew/perls/perl-5.12.2/lib/site_perl/5.12.2/x86_64-linux /home/yt/perl5/perlbrew/perls/perl-5.12.2/lib/site_perl/5.12.2 /home/yt/perl5/perlbrew/perls/perl-5.12.2/lib/5.12.2/x86_64-linux /home/yt/perl5/perlbrew/perls/perl-5.12.2/lib/5.12.2 .) at (eval 901) line 3.
2011/01/27 15:19:20 - CRITICAL - install_driver(sqright) failed: Can't locate DBD/sqright.pm in @INC (@INC contains: /home/yt/perl5/perlbrew/perls/perl-5.12.2/lib/site_perl/5.12.2/x86_64-linux /home/yt/perl5/perlbrew/perls/perl-5.12.2/lib/site_perl/5.12.2 /home/yt/perl5/perlbrew/perls/perl-5.12.2/lib/5.12.2/x86_64-linux /home/yt/perl5/perlbrew/perls/perl-5.12.2/lib/5.12.2 .) at (eval 901) line 3.
Perhaps the DBD::sqright perl module hasn't been fully installed,
or perhaps the capitalisation of 'sqright' isn't right.
Available drivers: DBM, ExampleP, File, Gofer, Proxy, SQLite, Sponge.
 at /home/yt/perl/warn.pl line 13

ちなみにこちらの記事によれば、これだけでは処理が不十分のようで、$^Sを使ってeval経由の呼び出しか否か(=本当にdieする時)で処理を分けた方が良い様です。

[Perl]Hachioji.pm #1

LTしました!

「Perlで杉を伐採しよう」という、タイムリーかつ割とどうでもいい様な話題を扱いました＞＜

Perlで杉を伐採しよう！ / Felling with Perl

View more presentations from ytnobody.

まとめについては･･･

hide_o_55さんの記事がまとめとして秀逸です！

酔魔の猛攻を潜り抜けた記憶を書き溜めておきます＞＜

・「寒い」という会場に関する前情報があったものの、「意外とあったかいじゃない！」
・次回は２月開催予定
・サイトを用意しよう！
　＞すでにドメインは取ったけど、MTかwikiのどっちを採用するか迷ってる
・サイトのデザインどうしよう。。
　＞水色を基調にオレンジをちりばめる感じで
・今後の連絡手法をどうするか
　＞Hachioji.pmのついったーアカウントを用意しよう
　＞ちなみにIRCも用意してます irc@freenode#hachiojipm ってかおまいらスルーすんな(ﾟДﾟ)ｺﾞﾙｧ!wwww
・uzullaさん「俺以外の人にも幹事任せたいんだよねー」
　＞遠征のタイミングで、遠征先在住の方が担当したり・・・？
・次回のLTはPerl以外で
　＞Hachioji.pmって何の略か知ってる？
　＞＞まかまかさん「八王子プログラマー・マウンテン！」
　＞＞＞どこにもPerlって書いてないよね！だからOK！！！

個人的に

ono_pmさんのLTにあったIPv4アドレスの枯渇予想を聞いて、空恐ろしく感じましたね。
だって、今年の2/2には枯渇する見込みですからね。ちょっとｺﾜｰって。

そんなこんなで

18:00開始にもかかわらず、23:30まで14名の男たちがクダをまいていましたｗ
そんなトレンディPerl(?)をこよなく愛するHachioji.pmに、みんなも参加してね～＞＜

[Perl]Solution for when access to CPAN Meta DB was denied to cpanm

I want to read this topic especially who lives in China --- if you can see this website ---.

If you are waited for cpanm so long long time, maybe, cause is deny of access to CPAN Meta DB.

$ cpanm Data::Model
...
...
### a minute later... ###
...
... omg, too late.
...
### 5 mins later... ###
...
... Ahhhhhhh!! so long! 
...

I was encountered this case on server in Beijin.
I guess, because Google App Engine was denied to access from China, and CPAN Meta DB works on GAE.

A solution.

$ cpanm --mirror http://www.cpan.org/ --mirror-only Data::Model

Clever cpanm! :)

miyagawa++;

[ネットライフ]githubデビューしました

実はアカウント自体去年からあったのですが、ついにレポジトリを2つ公開し、事実上のgithubデビューと相成りました。

ytnobody's Profile - GitHub

みなさんよろしくお願いしますm(_ _)m

Acme-JapaneseCedar

ytnobody/Acme-JapaneseCedar - GitHub
hachioji.pm #1のLTにてネタとしますw

Zacro

ytnobody/Zacro - GitHub
語源は果物の「柘榴」。memcachedプロトコル対応のジョブキューイングサーバです。
以前に自作「ニートサーバ」でベンチマークをとったMemcached::Server使ってます。

[Perl]Memcached::Serverで作ったニートサーバのベンチマークをとってみた

CPANにMemcached::Serverというモジュールがあるんですが、これを使うと、PerlだけでMemcachedプロトコルに対応したオレオレサーバが作れるんです。
で、このモジュールのサンプルでもあるMemcached::Server::Defaultのドキュメントに、

It works like a normal Memcached server, but not good at efficiency as the real one.

なあんて書いてあるので、
「じゃあMemcached::Serverで作ったニート(=仕事をしない)なサーバなら、どのくらいのパフォーマンスが出るのよ？」
という疑問を抱いてしまい、実際にニートサーバをでっち上げて、本家memcachedとのパフォーマンス比較をしてみました。

ニートサーバのソース

「働いたら負けかなと思っている」(AA略)

use warnings;
use strict;
use AnyEvent;
use Memcached::Server;
my $server = Memcached::Server->new(
    no_extra => 1,
    cmd => {
        set => sub { shift->(1) },
        get => sub { shift->(0) },
        delete => sub { shift->(1) },
        flush_all => sub { shift->() },
    },
    open => [ [ 0, 11222 ] ],
);

AE::cv->recv;

ベンチマークコード

普段あまりベンチマークコード書かない子なのがバレバレですね。。。＞＜

use warnings;
use strict;
use Benchmark qw( :all );

use Cache::Memcached::Fast;

my $origin_if = Cache::Memcached::Fast->new( { servers => [ qw/ 127.0.0.1:11211 /] } );
my $mine_if = Cache::Memcached::Fast->new( { servers => [ qw/ 127.0.0.1:11222 /] } );

my @patterns = (
    { method => 'set', params => [ 'hoge', 123 ] },
    { method => 'get', params => [ 'hoge' ] },
    { method => 'delete', params => [ 'hoge' ] },
);

for my $pattern ( @patterns ) {
    my $method = $pattern->{ method };
    warn "------ $method ------\n";
    my $r = timethese( 100000, {
        origin => sub { $origin_if->$method( @{ $pattern->{ param } } ) },
        mine => sub { $mine_if->$method( @{ $pattern->{ param } } ) },
    } );
    cmpthese $r;
}

ベンチ結果

ニートサーバと本家サーバを起動し、ベンチマークコードを実行した結果、興味深い結果に。。。

------ set ------
Benchmark: timing 100000 iterations of mine, origin...
      mine: 27 wallclock secs ( 1.79 usr +  3.15 sys =  4.94 CPU) @ 20242.91/s (n=100000)
    origin:  8 wallclock secs ( 1.43 usr +  3.03 sys =  4.46 CPU) @ 22421.52/s (n=100000)
          Rate   mine origin
mine   20243/s     --   -10%
origin 22422/s    11%     --
------ get ------
Benchmark: timing 100000 iterations of mine, origin...
      mine: 20 wallclock secs ( 1.25 usr +  3.17 sys =  4.42 CPU) @ 22624.43/s (n=100000)
    origin:  7 wallclock secs ( 1.21 usr +  3.11 sys =  4.32 CPU) @ 23148.15/s (n=100000)
          Rate   mine origin
mine   22624/s     --    -2%
origin 23148/s     2%     --
------ delete ------
Benchmark: timing 100000 iterations of mine, origin...
      mine: 19 wallclock secs ( 1.64 usr +  3.25 sys =  4.89 CPU) @ 20449.90/s (n=100000)
    origin: 15 wallclock secs ( 2.94 usr +  6.05 sys =  8.99 CPU) @ 11123.47/s (n=100000)
          Rate origin   mine
origin 11123/s     --   -46%
mine   20450/s    84%     --

おおおお！なんと！setとgetでは本家サーバに負けたものの、deleteではニートサーバがブッちぎりで勝利してます！！！
まあニートなので、Memcached::ServerとAE以外は何も仕事していないのですけど。。。
getにしても、2%の差に留まっているのは、まずまず悪くない結果です。
あとはsetがもう少し速ければ、安定性と載せるロジック次第で結構面白いものになるのではないでしょうか。

[Perl]Data::ModelでつくったスキーマクラスをMouseでくるんでdriver食わせたりしてみた

明けましておめでとうございます。Hachioji.pm#1のLTで何か話したいけど、何を話すか決めきれていないytnobodyです。

かなり前に[Perl]Data::ModelをMouseでextendsしたけどあんまり意味なかった。というメモ。という記事を書いたのですが、2年の時を経てもう一度同じ事をしてみました。
今回もご多分に漏れず備忘録的な記事ですが、今回はちゃんと「意味あるんじゃね？」という風に思わせているはずです。。。

スキーマクラス

ユーザに関する情報(=userスキーマ)をtokyotyrantに食わせ、ユーザーIDと登録タイムスタンプをSQLiteに食わせる、というデータ構造になってます。

package MySchema;

use Mouse;
use MouseX::Foreign qw/ Data::Model /;
use Data::Model::Schema;

has dbi => ( is => 'rw' );
has tyrant => ( is => 'rw' );

sub BUILD {
    my $self = shift;

    install_model user => schema {
        schema_options model_name_realname => 'u';
        key 'id';
        columns qw/ id name sex place favorite /;
        schema_options column_name_rename => {
               id => 1,
               name => 2,
               sex => 3,
               place => 4,
               favorite => 5,
        };
    };

    install_model user_list => schema {
        key 'user';
        driver $self->dbi;
        column user => varchar => {
            required => 1,
        };
        column datein => integer => {
            default => sub { time() },
        };
    };

}

no Mouse;
1;

Data::Modelを継承するために、MouseX::Foreignを使っています。これは、Mouse-0.71から非MouseなクラスをMouseで継承する上で、MouseX::Foreignというモジュールを使う必要があるためです。Mouse作者のブログでも明記されてますので、ぜひご一読を。
hasで宣言されているアクセサはそれぞれ、Data::Model::Driver::MemcachedとData::Model::Driver::DBIのオブジェクトを受け取る為の窓口となります。
本来のスキーマ定義はBUILDメソッド内に納めることになりますが、当然アクセサをそのまま使えますので、$self->dbi の様な記述もまかり通ります。

モデルクラス

スキーマクラスとアプリケーションの間を取り持つクラス。
このクラスを通して、スキーマオブジェクトを生成させるのですが、その時にD::M::D::MemcachedやD::M::D::DBIの設定をある程度やってくれるようにしてみました。

package MyModel;

use warnings;
use strict;

use Mouse;
use MySchema;
use Cache::Memcached::Fast;
use Data::Model::Driver::Memcached;
use Data::Model::Driver::DBI;

has dbi_options => ( is => 'ro', isa => 'HashRef' );
has memcached_options => ( is => 'ro', isa => 'HashRef' );
has schema => ( is => 'rw' );

sub BUILD {
    my $self = shift;
    my $tyrant = Data::Model::Driver::Memcached->new(
        memcached => Cache::Memcached::Fast->new( $self->memcached_options ),
        namespace => 'hoge',
        serializer => 'Default',
        strip_keys => 1,
    );
    my $dbi = Data::Model::Driver::DBI->new( %{ $self->dbi_options } );
    my $schema = MySchema->new( tyrant => $tyrant, dbi => $dbi );
    $schema->set_base_driver( $schema->tyrant );
    $self->schema( $schema );
}

around new => sub {
    my $super = shift;
    my $class = shift;
    my $self = $class->$super( @_ );
    return $self->schema;
};

no Mouse;
1;

アプリケーション

ただレコードをsetしてData::Dumperで吐かせるだけの簡単なお仕事です。

use warnings;
use strict;

use MyModel;
use Data::Dumper;

my $model = MyModel->new(
    memcached_options => {
        servers => [qw[ 127.0.0.1:11211 ]],
        namespace => 'hoge',
    },
    dbi_options => {
        dsn => 'dbi:SQLite:dbname=mymodel.db'
    },
);

$model->set(
    user => 'user001' => {
        name => 'ytnobody',
        place => 'sagamihara',
        sex => 'male',
        favorite => 'soba',
    }
);

$model->set(
    user_list => 'user001'
);

print Dumper( $model->lookup( user => 'user001' )->get_columns );
print Dumper( $model->lookup( user_list => 'user001' )->get_columns );

実行結果は以下の様になり、レコードのsetおよびlookupが出来ていることがわかります。
(2回目以降の実行では、レコードのsetで失敗しますので、エラーとなります。)

$VAR1 = {
          'favorite' => 'soba',
          'place' => 'sagamihara',
          'name' => 'ytnobody',
          'id' => 'user001',
          'sex' => 'male'
        };
$VAR1 = {
          'user' => 'user001',
          'datein' => '1294213651'
        };

モデルクラスの記述次第では、D::M::D::Memcachedのようなインスタンスをパラメータに求めるタイプのドライバすらも、インスタンスではなく接続先アドレスの指定のみで動作します。当然、モデルクラスとスキーマクラスを1つにまとめることも可能です。yamlなどの設定ファイルにモデルクラスの設定項目を書き出しておくことが容易になり、他のサーバへのアプリケーション移行時にも役に立ちそうです。