が、この子は PurePerl で実装されているので実行速度が結構遅いです。

どのくらい遅いかというと

use strict;
use warnings;
use Benchmark qw(cmpthese :hireswallclock);
use Data::Dump ();
use Data::Dumper ();

my $data = {
    foo => [qw/bar/],
    bar => {
        hoge => 'piyo',
    },
    heavy => So::Heavy::Object->new(10),
};

cmpthese -1, {
    'Data::Dump' => sub {
        my $res = Data::Dump::dump($data);
    },
    'Data::Dumper' => sub {
        my $res = Data::Dumper::Dumper($data);
    },
}, 'all';

package So::Heavy::Object;

sub new {
    my ($class, $depth) = @_;
    bless [ $depth, $depth ? $class->new(--$depth) : () ], $class;
}

こんなのを実行すると、

Benchmark: running Data::Dump, Data::Dumper for at least 1 CPU seconds...
Data::Dump: 1.09744 wallclock secs ( 1.09 usr  0.00 sys +  0.00 cusr  0.00 csys =  1.09 CPU) @ 1644.04/s (n=1792)
Data::Dumper: 1.0532 wallclock secs ( 1.05 usr  0.00 sys +  0.00 cusr  0.00 csys =  1.05 CPU) @ 10240.00/s (n=10752)
                Rate   Data::Dump Data::Dumper
Data::Dump    1644/s           --         -84%
Data::Dumper 10240/s         523%           --

こんくらいの差がでる。

Web アプリケーションなどで log を出す場合には、Data::Dumper を使ったほうがオーバーヘッドが少ないし、

local $Data::Dumper::Terse  = 1;
local $Data::Dumper::Indent = 0;
local $Data::Dumper::Pair   = '=>';

みたいにすると一行にみっちりと詰まって出るのでよいですね。インデントとか余計な物が消えて、出力される文字の量が減るので実行速度も若干上がるし*1、ディスク容量の削減にもつながってハッピーです。

ただし、 $Data::Dumper::Useqq = 1 とかするとかなり遅くなるので注意が必要。
改行されたデータが食わされる可能性があったら使わざるを得ないかもしれませんが。

あと、あんまり関係ないけどテストとかで Data::Dumper とかを使ってるコードをたまに見かけますが

use Test::More;
use Data::Dumper;

# do something...

warn Dumper $data

# do something...

これは

use Test::More;
# do something...

note explain $data;

# do something...

みたいに note explain {expr} 構文を使っとくと捗りますね。
別にどっちでもいいんですけど。

素直に Log::Minimal を使っておけばこのへんのこと考える必要が無いのでハッピーですね。

use strict;
use warnings;
use 5.12.1;
use Data::Dumper;

my @data = (
   ['nekokak', '1130', '1900'],
   ['nekokak', '1000', '1800'],
   ['zigorou', '1230', '2000'],
   ['zigorou', '1130', '2100'],
   ['xaicron', '1300', '2200'],
   ['xaicron', '1400', '2330'],
);

$Data::Dumper::Terse  = 1;
$Data::Dumper::Indent = 0;
say join "\n", Dumper sort {
    $a->[0] cmp $b->[0] or $b->[1] <=> $a->[1] 
} @data;

復数の条件でソートしたい場合は、or で連結していけばよい。

perldoc -f sort するといろんなレシピがあって結構楽しいです。

pipe() とか socketpair() とか色々方法はあるけど、素直に IO::Pipe 使っとくと簡単便利。コアモジュールですし。

use strict;
use warnings;
use IO::Pipe;

my $pipes    = [];
my $children = [];
for my $i (1..10) {
    push @$pipes, my $pipe = IO::Pipe->new;
    my $pid = fork;
    if ($pid) {
        # parent
        $pipe->reader;
        push @$children, $pid;
        next;
    }
    # child
    die $! unless defined $pid;
    $pipe->writer;
    print {$pipe} "pid: $$, index: $i\n";
    exit;
}

for my $pid (@$children) {
    waitpid($pid, 0);
}

for my $pipe (@$pipes) {
    print <$pipe>;
}

この書き方だと、すべての子プロセスの終了を待ってから初めて親プロセスで読み込みを始めているけど、use POSIX 'wait_h' して waitpid(-1, WNOHANG) すれば終わった奴から読み込めるはず。

pipe だと、送受信できるサイズに限界があるので、ファイルを使ったほうが巨大なデータを送る場合は安全。

use strict;
use warnings;
use File::Temp qw(tempdir);
use File::Slurp qw(write_file read_file);

my $tmpdir = tempdir CLEANUP => 1;

my $children = [];
for my $i (1..10) {
    my $pid = fork;
    if ($pid) {
        # parent
        push @$children, $pid;
        next;
    }
    # child
    die $! unless defined $pid;
    write_file "$tmpdir/$$", "pid: $$, index: $i\n";
    exit;
}

for my $pid (@$children) {
    waitpid($pid, 0);
    print read_file "$tmpdir/$pid";
}

pipe の時と基本的な書き方は変わらない。pid 毎にファイルを作っておいたほうが何かと便利かもってぐらい。

ちなみに pipe もファイルも単なるバイト列しか送受信できないので、データ構造を送りたい場合はなんかしらのシリアライザーを使う必要がある。JSON とか Data::MessagePack とかそのへん。

ちなみに、Parallel::ForkManager 0.7.6 からは、run_on_finish() で子プロセスからデータを受信できる。
実際には、子プロセスの finish() のタイミングで pid 毎にファイルに Storable::store() して、親プロセスでは Storable::retrieve() しているので、さっき書いたようなことと一緒。

use strict;
use warnings;
use Parallel::ForkManager 0.7.6;
use Data::Dumper;

my $pm = Parallel::ForkManager->new(3);
$pm->run_on_finish(sub {
    my ($pid, $exit_code, $ident, $exit_signal, $core_dump, $data) = @_;
    print Dumper $data;
});
for my $i (1..10) {
    $pm->start and next;
    $pm->finish(0, { pid => $$, index => $i });
}

$pm->wait_all_children;

プロセス間通信ってめんどいですね。

ちなみに、ここに書いてあるプログラムはエラーハンドリングとかシグナルとか考慮してないし、いろいろとあれです。親プロセスから子プロセスに書きこむやつとか書いてないし。めんどいから DBD::SQLite っていうのもありですね。

あと、別に fork したいんじゃなくて並列処理をしたくてその結果を受け取りたいんだぜって場合は Coro::Channel とか使うとシンプルに書けるんじゃないかと思います。

• 1月
• エロ画像を収集してた
• 2月
• Furl をいじりだした
• 3月
• Kagura っていう　WAF を書いてた
• 地震で漫画がすべて本棚から落ちる
• 4月
• Amazon.co.uk で 攻殻機動隊全部揃えた (まだ観終わってない)
• Sub::Retry にパッチ送った
• CPAN モジュールガイド購入
• 5月
• dotcloud が始まったりした
• Yokohama.pm#7
• DNS とか調べてたっぽい
• atsort コマンド作成
• 6月
• perl segv golf
• クリスマス
• WEB+DB Press vol.63 に記事が載った
• 7月
• App::envfile 書いた
• Test::Flatten 書いた
• Furl に執拗にパッチ送った
• 8月
• Data::WeightedRoundRobin 書いた
• C80
• 四半世紀経過
• ISUCON で文字化け FAILED
• 9月
• IO::Prompt::Simple 書いた
• 閃乱カグラ！！！１
• configure_requires について
• perl は言語内にイテレーターないからあれげ
• 10月
• YAPC::Asia 2011
• いろいろとモジュール更新してた
• 11月
• Test::Mock::Guard とかいじってた
• is_deeeeeeeeeply
• Yokohama.pm#8
• 12月
• Perl Advent Calendar
• MySQL Casual Advent Calendar
• WEB+DB Press vol.66 にグラビア写真が載った
• C81

そういう時は、

$ENV{PERL_LWP_SSL_VERIFY_HOSTNAME} = 0;

とすれば OK ですね。っていうのを zigorou さんに教えてもらいました。ちなみにこの ENV は LWP::Protocol::https にはコードの中にしか出てこなくて、LWP*1 の POD に書かれてました。

あとは、

LWP::UserAgent->new(ssl_opts => { verify_hostname => 0 });

でもいいですね。こっちは LWP::Protocol::https に書いてありました。ちゃんとドキュメント読めって感じですが、LWP はいろんなところに分散していて、ちょっとした機能がなかなか探しづらいですね。

よくみたら、普通に LWP::UserAgent の POD に書いてあって

$ua->ssl_opts(verify_hostname => 0);
say $ua->ssl_opts('verify_hostname'); # 0

とかできるし、PERL_LWP_SSL_VERIFY_HOSTNAME のことも書いてあったので、本当にちゃんとドキュメント読みましょう！！１１１

さて、自分は MySQL のこととかあんまりよくわからないんですが、仕事で Q4M とか HandlerSocket とか使う機会があります。
更に言うと、手元の Mac の環境でそれらを手軽に使いたいので、簡単にセットアップが出来ると嬉しいですね。

というわけで、一発で MySQL と Q4M と HandlerSocket のセットアップが出来ちゃうシェルスクリプトを書きました！大変カジュアルですね！！

前提条件として、Xcode と homebrew は入っているものとします。

$ zsh -c "$(curl -fsSL https://raw.github.com/gist/1426403)"

とか実行すればOKです！

このスクリプトのとってもカジュアルなところを2、3説明すると、

1. brew install の時に一回 MySQL をビルドしてるけど終わると消えちゃうので、もう一回ビルドしている
2. テストとか一切走らせない
3. エラーが起きてもお構いなしに最後まで処理する

といったところでしょうか。

ちなみに、MySQL5.1系を入れているのは Q4M が現時点では 5.1系しか対応していない為です。
HS は 5.5とかでも普通に動くよって作者の人が言ってました。

という訳で、コマンド一発叩くだけで手元で Q4M と HS が入った状態の MySQL5.1 が手に入るのでとってもお手軽で良い感じですね。
誰かバイナリ配布してください

さて、明日は椅子とMySQL4をこよなく愛するスーパーインフラエンジニアの kazeburo さんです。
お楽しみに！！

今年は Test Track っていうのをやっているので、テストに一家言あるぜっ！て人はぜひぜひ参加してみてください！

募集は ATND で行なっていますので、お気軽に。
記事の書き方は、コチラを参照してください。
writer 権限は twitter で @xaicron まで言ってくれれば追加します。

景品は、自分の書いた記事が、電子書籍化される権利です！今すぐ応募しよう！！

はてさて、25日書けるかな？

ちなみに、App::cpanminus の 1.5000 以上を使っている場合、モジュールのインストール情報がとある場所に保存されるようになったので、pm-uninstall の 0.25 からはそれを元にモジュールを削除するようになったので、新しいバージョンを使っているといいことがあると思います。*1

ただし、まだまだEXPERIMENTALな機能なので、今後も変更があるかもしれませんです。

っていうのを最近 id:antipop さんに聞かれたので忘れないうちにメモっておくの巻。

そういえば、初参加からずっと何かしらトークしてますね。

今回は直前に仕事がいろいろと舞い込んできてしまったので何もネタを用意できておらず、どうしようかなーと思っていましたが、なんとなく会場に行くまでの電車の中で思いついたので良かったです。

会場についてから Yahoo API アカウント取ったり、頑張ってモジュール書いたり irc bot を書いたりプレゼン書いたりとやってて結構大変でしたが、なんとかなりましたね。

コードは以下にあげときました。

xaicron/p5-Acme-Shiin - GitHub

LT 見てない人のために簡単に説明すると、マジレス -> mjrs とか 確かに -> tskn にしてくれる超便利で鼻毛が出ちゃうモジュールです。

use Acme::Shiin;

my $config = pit_get('Acme::Shiin', require => {
    app_id => 'your app_id',
});
my $shiin = Acme::Shiin->new(app_id => $config->{app_id});
say $shiin->shiinize('マジレス'); # mjrs

漢字をひらがなに変換するために、Yahoo のルビ振り API を使っているので Yahoo appId が必要です。

処理の流れとしては

1. 漢字をひらがなに
2. カタカナをひらがなに
3. 母音を削除
4. 手で頑張って書いたマップで適当に置換する

とかでだいぶ適当な実装ですね。XML はめんどかったんで、自力で正規表現でぶっこぬいてます。

ちなみに irc bot は AnySan があったのですごい簡単でしたね。ほぼ SYNOPSYS のコピペです。

#!/usr/bin/env perl

use strict;
use warnings;
use lib 'lib';
use AnySan;
use AnySan::Provider::IRC;
use Config::Pit;
use Acme::Shiin;

my $config = pit_get('Acme::Shiin', require => {
    app_id => 'your app_id',
});
my $shiin = Acme::Shiin->new(app_id => $config->{app_id});

my $irc = irc
    'localhost',
    port     => 6667,
    key      => 'oppai',
    nickname => 'shiinize',
    channels => {
        '#shiin' => {},
    };          

AnySan->register_listener(
    shiinize => {
        cb => sub {
            my $receive = shift;
            my $ret = $shiin->shiinize($receive->message);
            $receive->send_replay($ret);
        },
    },
); 

AnySan->run;

やっぱり一番大変だったのは、ひらがなのマップを作るところでしたし、意外とひらがなって羅列できないですねってことがわかりました。
次回は体調万全で挑みたいと思います。

また、いつも mjrs してくれる gfx 氏にこのモジュールを捧げます。

use strict;
use warnings;
use Test::More;
use String::Diff;
use Data::Dumper;
use Term::ANSIColor qw(color);

sub is_deeeeeeeeeply {
    my ($got, $expects, $desc) = @_; 
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    local $Data::Dumper::Terse    = 1;
    local $Data::Dumper::Sortkeys = 1;
    local $Data::Dumper::Indent   = 0;
        
    my $got_str     = Data::Dumper::Dumper($got)."\n";
    my $expects_str = Data::Dumper::Dumper($expects)."\n";
    ok $got_str eq $expects_str, $desc or do {;
        note String::Diff::diff($got_str, $expects_str, (
            remove_open  => color('black on_red'),
            remove_close => color('reset'),
            append_open  => color('black on_green'),
            append_close => color('reset'),
        )); 
    };  
}

is_deeeeeeeeeply [ nekokak => { dis => 'false' } ], [ nekokak => { dis => 'true' } ], 'really?';

done_testing;

まぁ CPAN には Test::Differences::Color とかいろいろありますね。

copmact するときに、SQL::Tokenizer に依存していたんだけど、あんまり良い感じになってなかったので自力で SQL を Parse してほげほげすることにしました。

なんか壊れてるんじゃねっ！って思ったらテストケース送ってくれれば対応しますです。

主に、とあるメソッドでの条件分岐などで、呼び出されたかどうかを知りたい場合に使います。

use strict;
use warnings;
use Test::More;
use Test::Mock::Guard qw(mock_guard);

{
    package SomeClass;
    
    sub new { bless {}, __PACKAGE__ }

    sub some_method {
        my ($self, $args) = @_;
        return $args ? $self->foo : $self->bar;
    }

    sub foo { 'foo' }

    sub bar { 'bar' }
}

my $obj = SomeClass->new;

subtest 'called foo' => sub {
    my $guard = mock_guard $obj => {
        foo => 'hoge',
        bar => 'fuga',
    };
    is +$obj->some_method(1), 'hoge';
    is $guard->call_count($obj, 'foo'), 1;
    is $guard->call_count($obj, 'bar'), 0;
};

done_testing;

こんな感じで簡単ですね。

ちなみにスタブ化してないメソッドに対して call_count をやると、undef が返ってきますが、あんまり気にしなくていいでしょう。

最近は、以下のようにしてる。

--exec "perl -Ilib -It/lib -MTest::Flatten -MTest::Name::FromLine"
--color
--merge
--timer
-w

こんくらい書いておくとまぁ大体いい感じになる。

あと、color と compresscompact と useqq っていうオプションを追加しました。
それぞれ env DBIX_QUERYLOG_(COLOR|COMPRESSCOMPACT|USEQQ) とかでも設定できます。

軽く例を上げると、useqq は

# local $Data::Dumper::Useqq  = 1;
# local $Data::Dumper::Terse  = 1;
# local $Data::Dumper::Indent = 0;
# とした Data::Dumper::Dumper を通す
DBIx::QueryLog->useqq(1); # or $ENV{DBIX_QUERYLOG_USEQQ} = 1
my $row = $dbh->selectrow_hashref(<< 'SQL', undef, 'nekokak');
SELECT * FROM
   dis
WHERE name = ?
SQL
# => "SELECT * FROM\n    dis\nWHERE name = 'nekokak'\n"

って感じになります。

compresscompact は空白を全部スペース一個に変えます。SQL::Tokenizer とか使ってるのでそのへんのオーバヘッドはあるでしょう

DBIx::QueryLog->compresscompact(1); # or $ENV{DBIX_QUERYLOG_COMPRESSCOMPACT} = 1
my $row = $dbh->selectrow_hashref(<< 'SQL', undef, 'nekokak');
    SELECT * FROM
    dis
WHERE      name = ?
SQL
# => SELECT * FROM dis WHERE name = 'nekokak'"

SQL を完全なまま再現したいけど一行にしたい場合は、useqq で、壊れてもいいから短くしたいなら compress ってところですね。
いちおう、useqq は unprintable な文字を printable にしてくれるっていう副作用もあるので、両方指定するのもありです。

あと、color はそのまんまで、Term::ANSIColor のやつを使えます。

DBIx::QueryLog->color('black on_yellow'); # or $ENV{DBIX_QUERYLOG_COLOR} = "black on_yellow"

ちなみに、自分は DBIx::QueryLog は本番環境でがっつり使うってよりは、手元の環境とかでデバッグ時に use してやるだけで全部の SQL が吐かれるので便利って感じで使ってます。
メソッドをラップするので、若干のオーバヘッドがありますし。

本番環境とかでその瞬間の SQL をトレースしたい場合は、tcpdump を使ったほうが効率的ですね！

version 0.18 から、Log::Minimal みたいに、$OUTPUT に sub { ... } を渡せるようになりましたので何でもやり放題ですね。やった！

local $DBIx::QueryLog::OUTPUT = sub {
    my %args = @_;
    printf "%s\n", $args{sql};
};

%args に何が渡ってくるかは、POD を参照のこと。

Data::WeightedRoundRobin は重み付けされた値をベストエフォートな感じでラウンドロビンしてくれるモジュールです。

使い方は簡単で、以下のような感じ。

use Data::WeightedRoundRobin;

my $wrr = Data::WeightedRoundRobin->new([
    { value => 'hidek',   weight => 65 },
    { value => 'zigorou', weight => 80 },
    { value => 'nekokak', weight => 75 },
]);

say $wrr->next for 1..100;

こうすると、大体

hidek : zigorou : nekokak = 65 : 80 : 70

ぐらいの頻度で返ってきます。
例でわかるように、別に weight を百分率にする必要も特になく、0 以上の値なら何でも良いです。0.1とか。

DB への負荷分散では、value に IP を突っ込んでやってます。そうすると、DNSルックアップがなくなってハッピーです。

とりあえず、手元の MBA で next のベンチとってみたら、秒間34万回とか出てたので、まぁまぁいいんじゃないでしょうか。