Perlの最近のブログ記事

相変わらず、題名にセンスがありません。こんばんは。

さて、ようやくローンチしたモバゲーオープンプラットフォームですが、仕組み的にはmixiさんのモバイル版とほぼ同じアーキテクチャで Gadget Server がプロキシー的な役割をする感じになってます。

図面1

大人の事情がかなり反映された仕組みなのですが、この仕組みで非常に重要なのがGadget ServerからのリクエストをSAPがいかに信頼するかという部分です。いわゆる 2-legged OAuthでAuthorizationヘッダに含まれるOAuth Signatureの検証する部分。その部分のコードスニペットをご紹介。(mixi 用のは公開していいかどうかわかんないのでモバゲー向けだけ)

use OAuth::Lite::ServerUtil;
use OAuth::Lite::Util qw/parse_auth_header/;
use CGI;

my $consumer_secret = 'YOUR_CONSUMER_SECRET';

sub validate_signature {

    my $cgi = CGI->new;

    my ($realm, $params) = parse_auth_header($ENV{HTTP_AUTHORIZATION});

    for my $key ($cgi->url_param) {
        $params->{$key} = [$cgi->url_param($key)];
    }

    if (uc $cgi->request_method eq 'POST'
        && $cgi->content_type =~ m{^\Qapplication/x-www-form-urlencoded})
    {
        for my $key ($cgi->param) {
            $params->{$key} = [$cgi->param($key)];
        }
    }

    my $util = OAuth::Lite::ServerUtil->new(strict => 0);
    $util->support_signature_method('HMAC-SHA1');

    return $util->verify_signature(
        method          => $cgi->request_method,
        url             => $cgi->url,
        params          => $params,
        consumer_secret => $consumer_secret,
        token_secret    => $params->{oauth_token_secret},
    );
}

Apacheで動かす場合にはCGIからAuthorizationヘッダを取得することができないので mod_rewriteで

RewriteEngine on
RewriteBase /
RewriteCond %{HTTP:Authorization}  ^(.*)
RewriteRule ^(.*)$ $1 [e=HTTP_AUTHORIZATION:%1]

こんな風にしないと環境変数からは取れない。

Net::OAuthっていうモジュールもあるけど個人的にはlyokato氏謹製のOAuth::Liteの方が圧倒的に使いやすいのでこっちをつかってます。

で、このままmixiさんで動くかというと、そうでもなく両者の間には若干差があって、mixiさんは純粋な 2-legged OAuth なんだけど、モバゲーの場合は若干パラノイア的で、Gadget Server がリクエストごとに発行する Access Tokenが含まれるため、それも含めて検証する必要があります。あとPOSTの場合の挙動がちょっと違うかも。

というか、この部分って毎回検証する必要があるのだから、WAFやApplicationというよりはmod_auth_*とかPlack::Middlewareとかで何とかするレイヤーな気がしてならないので、そのうち作りたいな。

今年もPerl hackersの祭典、YAPC::Asiaが始まりました。


RIMG0383


スライドを1文字も書いていないのに前夜祭で盛大に飲んでしまい、朝何とか早起きして草稿を作って、発表の5分前まで書いて発表というとんでもない綱渡りをしましたが、何とか自分のトークは終わりました。スライドの方は後ほど公開したいと思います。

というわけで、猛烈に眠いですがここからは気楽に楽しもうと思います。

このところ、MySQL と Catalyst と 豆しば 関連のエントリをいろいろ書いていますが、それは、スケールアウト可能で、かつ、Catalystで動くアプリケーションを、今まさに作っている、という理由があるからです。

ただ、ブログエントリだとどうしても細切れになるので、一連のモジュールやプログラムを組み合わせて、どうやってスケールするウェブアプリケーションを作るのかという話を YAPC::Asia 2009 でさせていただくことにしました。

YAPC::Asia 2009 は9月10日(木)と11日(金)の2日間、東京工業大学大岡山キャンパスで開催されます。今日からチケット販売も始まったので、興味のある方はお越しいただければ、と思います。

【参考文献】

良くあるDBICのサンプルではDBIx::Class::Schema::load_classes()を使ってクラスのロードを行っています。

CD.pm
package CD;

use strict;
use warnings;

use base 'DBIx::Class::Schema';

__PACKAGE__->load_classes;
1;
load_classes()はクラスを指定しないと
CD
    Album
    Track

という構成において自動的にクラスをロードすることができます。

ここでResultSetの拡張をしたいと考えます。例えば

CD/ResultSet/Album.pm
package CD::ResultSet::Album;

use strict;
use warnings;

use base 'DBIx::Class::ResultSet';

sub search_order_title {
    my $self = shift;

    return $self->search({}, {'order_by' => 'title'});
}
1;

のようにDBIx::Class::ResultSetを継承したクラスを作ってCD::Album::resultset_class()でロードします。ここで問題になるのがこのクラスのネームスペースをどうするかという点です。

CD::ResultSet::*にしてしまうと、load_classes()でwarningが出る羽目になります。かといってload_classes(qw/Album Track/)などとクラスを指定するのもクラスが増えてきたときに大変そうです。またはResultSet::CD::AlbumのようにCDより上のネームスペー>スを使うのも、あんまりいけてない感じです。

そこでDBIC::Schemaにはもう一つクラスのロード手段としてload_namespaces()が用意されていているのこれを使います。

CD.pm
package CD;

use strict;
use warnings;

use base 'DBIx::Class::Schema';

__PACKAGE__->load_namespaces;
1;

load_namespaces()はデフォルトで

CD
    Result
        Album
        Track
    ResultSet
        Album

という構成をとります。

これのメリットはネームスペースがすっきりするだけではなく、ResutlSet::*にResutl::*と同じ名前のResutlSetクラスを作ると、Resultクラスでresutlset_class()で指定しなくても自動的にロードしてくれる点です。(ただ逆もまたしかりで、上の構成でResultSet::Hogeなどを作ると対応するResultクラスがないとwarningがでます。)

ちなみにDBIx::Class::Schema::Loaderを使ってデータベースからクラスを起こす場合は
perl -MDBIx::Class::Schema::Loader=make_schema_at,dump_to_dir:./lib -e 'make_schema_at "CD", {use_namespaces => 1, debug => 1}, ["dbi:SQLite:cd.db","",""]'
のようにuse_namespacesオプションを指定するといいです。

今回のコード

CD.pm
package CD;

use strict;
use warnings;

use base 'DBIx::Class::Schema';

__PACKAGE__->load_namespaces;
1;
CD/Result/Album
package CD::Result::Album;

use strict;
use warnings;

use base 'DBIx::Class';
__PACKAGE__->load_components(qw/Core/);
__PACKAGE__->table('album');
__PACKAGE__->add_columns(
    id => {
        data_type         => 'INTEGER',
        size              => 11,
        is_nullable       => 0,
        is_auto_increment => 1,
    },
    title => {
        data_type   => 'VARCHAR',
        size        => '255',
        is_nullable => 0,
    },
);
__PACKAGE__->set_primary_key('id');
__PACKAGE__->has_many(
    tracks => 'CD::Result::Track', 'album_id', {order_by => 'position'}
);
1;
CD/Result/Track.pm
package CD::Result::Track;

use strict;
use warnings;

use base 'DBIx::Class';
__PACKAGE__->load_components(qw/Core/);
__PACKAGE__->table('track');
__PACKAGE__->add_columns(
    id => {
        data_type         => 'INTEGER',
        size              => 11,
        is_nullable       => 0,
        is_auto_increment => 1,
    },
    album_id => {
        data_type   => 'INTEGER',
        size        => 11,
        is_nullable => 0,
    },
    position => {
        data_type   => 'TINYINT',
        size        => 1,
        is_nullable => 0,
    },
    title => {
        data_type   => 'VARCHAR',
        size        => '255',
        is_nullable => 0,
    },
);
__PACKAGE__->set_primary_key('id');
__PACKAGE__->add_unique_constraint(
    track_uq_album_id_position => [qw/album_id position/]);
__PACKAGE__->belongs_to(album => 'CD::Result::Album', 'album_id');
1;
CD/ResultSet/Album
package CD::ResultSet::Album;

use strict;
use warnings;

use base 'DBIx::Class::ResultSet';

sub search_order_title {
    my $self = shift;

    return $self->search({}, {'order_by' => 'title'});
}
1;

先日、カジュアルな飲み会の席でPerl 5.10が2007年12月19日にリリースされてから早1年半が経ったけど何か普及してなくない?って話をしてました。

そんな中、ノートのOSをUbuntu 8,04から9.04に変えてUbuntuは8.10からすでに5.10がデフォルトでインストールされてるということを知り、5.10は普及してないというのは自分の単なる思い込みかもしれないと思い、ちょっと調べることにしました。

で、見つけたのがDistroWatch.comという、300ちかいのLinux/BSDのディストリビューションの情報が紹介されているサイトで、ここからWeb::Scraperで各ディストリビューションの最新バージョンのPerlのバージョンをスクレーピングしてみました。ついでに最近見つけたChart::Clickerというモジュールでグラフを作ってみました。

結果は

foo

5.10.0124
5.8.8124
none29
5.8.76
5.8.64
5.8.03
5.8.43
5.8.93
5.8.53
5.8.21
5.9.41
5.6.11


と、5.8.8と5.10.0が同数という結果になりました。もちろんわけのわからんマイナーなディストリビューションや単なる派生ディストリビューションも含まれるのでこの情報にどこまでの意味があるかわかりませんが、なかなか面白い結果になりました。

そもそもメジャーなディストリビューションで5.10じゃないのはRHELとCentOSくらいです。(ともに6からはFedora 11ベースになるはずなので5.10になると思います。)後はDebian, Fedora, Ubuntu, openSUSE, Mandriva, Slackwareと軒並み5.10がデフォルトなので、ディストリビューションという観点からは中々の普及率と言えると思います。

後はレンタルサーバーのOSの移行がどこまで進むかにかかっていると思います。

ちなみに今回使用したコード

miyagawaさんが紹介されていたlocal::libを使って非rootでのCPAN環境を作ってみました。平たく言えばさくらインターネットのレンタルサーバで一般ユーザーでCPAN環境を作ってみました。

とはいえ、多くは先人たちの と大差ありません。

まずはlocal::libのアーカイブを取得・解凍します。最新のバージョンは1.003001です。

wget http://search.cpan.org/CPAN/authors/id/A/AP/APEIRON/local-lib-1.003001.tar.gz
tar xzvf local-lib-1.003001.tar.gz
cd local-lib-1.003001

otsuneさんの記事にある通り、BSDPANのエラーを回避する設定をします。自分はbashを使っていますが、さくらのデフォルトのcshellを使っている場合は適宜setenvなどに置き換えてください。

export PKG_DBDIR=$HOME/local/var/db/pkg
export PORT_DBDIR=$HOME/local/var/db/pkg
export INSTALL_AS_USER
export LD_LIBRARY_PATH=$HOME/local/lib
mkdir -p ~/local/var/db/pkg

local::libにはまっさらな状態からインストールすることを想定したbootstrapオプションがMakefile.PLにあり、CPANの設定もしてくれます。が、さくらのレンタルサーバにインストールされているCPANモジュールが古いのと設定がされてないため、urllistが設定されずに途中のインストールで失敗するので、CPANの設定を先に行います。

cpan
...
cpan> exit

質問に対しては基本的にデフォルトで(リターン連打) ミラーの選択だけAsia>Japanから選べばいいと思います。設定が終了したらCPANシェルを抜けます。(余談ですが、2月16日現在でcharsbarさんオススメの山形大学のミラーが2月6日付けで止まってる気がします。)

Makefileを作成します。

perl MakeFile.PL --bootstrap=$HOME/local
...

ちなみに$HOME/localを省略するとデフォルトの$HOME/perl5にインストールされます。

この時点で$HOME/local/lib/perl5以下にlocal::libが必要とするモジュールがインストールされます。

通常はこの後makeしてインストールすればよいのですが、たまにMakefileが作成されないことがあるので、その場合は先ほどのコマンドを再度実行します。

makeしてtestします。

make && make test
...
Files=2, Tests=6,  0 wallclock secs ( 0.04 cusr +  0.04 csys =  0.08 CPU)

問題なさげならmake installします。

make install

シェルの起動時に環境変数を設定するようにします。

echo 'eval $(perl -I$HOME/local/lib/perl5 -Mlocal::lib=$HOME/local)' >>~/.bashrc
cshellの場合は
echo 'perl -I$HOME/perl5/lib/perl5 -Mlocal::lib' >> ~/.cshrc

こうすることによりシェルが起動されると

export MODULEBUILDRC="/home/hidek/local/.modulebuildrc"
export PERL_MM_OPT="INSTALL_BASE=/home/hidek/local"
export PERL5LIB="/home/hidek/local/lib/perl5:/home/hidek/local/lib/perl5/i386-freebsd-64int:$PERL5LIB"
export PATH="/home/hidek/local/bin:$PATH"

という環境変数が設定されます。

後はいったんシェルを抜けるかsource ~/.bashrc(または.cshrc)してからいつものようにcpanシェルからinstall Bundle::CPANしてください。

なお、環境変数にPERL_MM_OPT="INSTALL_BASE=/home/hidek/local"が設定されているのでcpanシェルを使わずにインストールする時もperl Makefile.PL INSTALL_BASE=$HOME/libする必要なくperl Makefile.PLでよしなにしてくれます。

\mysql_enable_utf8 => 1 で DBIC::UTF8Columns 要らなくなるっぽい - 僕ト云フ事@はてな出張版

恥ずかしながら知りませんでした。
DBIx::Classの場合、DBIx::Class::UTF8Columnsを使ってutf8_columns()でUTF8フラグを立てたいカラムを指定するのですが、特定のカラムだけにUTF8フラグを立てるというのは稀で、全ての文字列のカラムに立てるのが多くの場合だと思います。
ので、DBDのレイヤーで吸収するこの方法が個人的にもベストプラクティスだと思います。
vkgtaro++

備忘でまとめておくと各DBDの接続オプションで

  • mysql: mysql_enable_utf8
  • postgresql: pg_enable_utf8
  • sqlite: unicode

に1を指定することにより、全ての文字列のカラムの値にUTF8フラグが立って返ってきます。

ちなみにmysqlのSET NAMES 'utf8'とかはサーバーに対するクライアントが使用する「文字コード」の宣言であってUTF8フラグとは直接関係ありません。

参考: Using Unicode - Catalyst::Wiki

Shibuya.pm Tech Talk #10でLTしてきました。
関係者の方々お疲れ様でした。

ニコニコ動画

題にはBenchmarkうんぬんかんぬん書いてありますが、今回自分はどっちかっていうとスピリチュアルな方向で話させてもらいました。
若干ネタに走ってしまって趣旨がぼやけましたが、はっきり言うとPHPに奪われたところを取り替えそうじゃないか。という問いかけです。
準備が足らなかったのに加えてしらふだったので、この次はアルコール注入してもっと熱く語りたいと思います。

HECon #1に行ってきたというより、コーディネートさせていただきました。
急遽決まった+SoozyConのノリで一時はどうなるかと思いましたが、皆様のご協力のおかげで無事終わることが出来ました。
この場を借りてお礼申し上げます。ありがとうございました。
また、会場整理に当たっていただいた同僚の皆様ご苦労様でした。助かりました。

で、僕は進行と懇親会の乾杯の音頭しかやってないので詳しくは

のあたりを見ていただきたいのですが、昨今のLightweight WAFs改めCGI Application FrameworksのブームなどもありHECon #2とかWAF Con #1とか言う話も出てるので、またお役に立てればと思います。

11月26日(水) にHTTP::Engineに関する勉強会、HE Conference #1が行われるので参加します。

HTTP::Engineだけではなく周辺技術やWSGI, Rackといった同様な技術に関しての発表もオーケーというかなりゆるい勉強会です。

日時: 2008年11月26日(水)
場所: 株式会社KDDIウェブコミュニケーションズ 6F セミナールーム
本編: 20:00 ~ 21:00
懇親会: 21:30~

参加はこちらのWikiを編集

スピーカー枠も参加者枠もまだまだ空きがあるのでふるってご参加ください。

来る11月27日(水)にShibuya Perl Mongersテクニカルトーク#10が行われます。

今回は何と4部構成で計15本ものトークがあるという豪華編成。
これを平日の夜から行おうというのだから正気の沙汰ではありません。
とはいえ今回はPerl以外の話もちょこちょこあるのでPerlユーザーだけじゃなく、全ての人が楽しめそうな感じです。

で、ボクは第二部 特別企画「最速Perlフレームワーク研究会」の頭にBenchmark of Perl Web Application Frameworks と題して話します。
ベンチマークを晒すだけじゃなく、何故21世紀にもなってCGIなのか?何故ベンチマークなのか?あたりを熱く語りたいと思います。

追記: 3部どころじゃなくて4部構成でした><

DBIx::Class::ResultSetManager - scheduled for deletion in 09000 - search.cpan.org
DBIx::Class::ResultSetManager never left experimental status and has now been DEPRECATED. This module will be deleted in 09000 so please migrate any and all code using it to explicit resultset classes using either __PACKAGE__->resultset_class(...) calls or by switching from using DBIx::Class::Schema->load_classes() to load_namespaces() and creating appropriate My::Schema::ResultSet::* classes for it to pick up.";

以前にも書きましたが、何かと問題ありつつもResultSetに簡単にメソッドをはやせるので便利だったDBIx::Class::ResultSetManagerです。
が、このたび0.09000からは削除されることになりました。

なので、その代替案が必要なのですが、基本的には以下のようにするのがよろしいようです。

use strict;
use warnings;

{
    package My::ResultSet::Users;
    use base qw/DBIx::Class::ResultSet/;

    sub search_ordered_desc {
        my $self = shift;
        return $self->search( {}, { 'order_by' => 'username DESC' } );
    }

    package My::Schema::Users;
    use base 'DBIx::Class';

    __PACKAGE__->load_components(";Core";);
    __PACKAGE__->table(";users";);
    __PACKAGE__->add_columns(qw/id username/);
    __PACKAGE__->set_primary_key(";id";);
    __PACKAGE__->resultset_class('My::ResultSet::Users');

    package My::Schema;
    use base qw/DBIx::Class::Schema/;

    __PACKAGE__->load_classes(qw/Users/);
}

my $schema = My::Schema->connect('dbi:SQLite:db.db');
my $rs = $schema->resultset('Users');
$rs->create( { username => ";user$_"; } ) for ( 1 .. 9 );

{
    my $users = $rs->search( {} );
    while ( my $user = $users->next ) {
        print $user->username, ";\n";;
    }
}

{
    my $users = $rs->search_ordered_desc;
    while ( my $user = $users->next ) {
        print $user->username, ";\n";;
    }
}

つまり、DBIx::Class::ResultSetを継承したクラスを用意してresultset_class()でロードしてやる感じです。

追記: タイトルがResultManagerになってました。もちろんResultSetManagerの間違いです。

CentOS 5.2を使ってるわけですが、勢いあまってperl-5.8.8-15.el5_2.1パッケージをインストールしてしまいました。

ちっ…とおもいつつ、SRPMSを取り寄せてperl.specを見てみると

* Thu Aug 28 2008 Marcela Maslanova <mmaslano@redhat.com> - 4:5.8.8-15.el5.1
- add upstream fix for bless/overload problem (changes 31996,32018,32019,
    32025) and perl-5.8.8-bug24254.patch. Without this patch had bless
    poor performance.
- Resolves: rhbz#460308

と、あります。

事実Yappoさんの書いた検証コードを走らせて見ると

Benchmark: timing 100000 iterations of not overload, overload...
not overload:  0 wallclock secs ( 0.34 usr +  0.00 sys =  0.34 CPU) @ 294117.65/s (n=100000)
            (warning: too few iterations for a reliable count)
  overload:  1 wallclock secs ( 0.33 usr +  0.00 sys =  0.33 CPU) @ 303030.30/s (n=100000)
            (warning: too few iterations for a reliable count)

とペナルティがなくなってます。

しかもPatch27509, Patch27512は当たったままなので当然overloadのバグが解消されてます。
試しに以下のコードを実行してみると

use strict;
use warnings;
package Foo;
use overload '""' => sub { 1 };

package main;
my %args;
my $a = \%args;
my $b = \%args;

bless $a, 'Foo';

warn $a;
warn $b;

こんな感じになります。

1 at hoge.pl line 14.
1 at hoge.pl line 15.

パフォーマンスペナルティもなくバグも直ってひゃっほー
…と思ったら落とし穴が orz

そう。あの鬱陶しいDBICのチェックwarningsです。
前にも書きましたが、DBIx::ClassでuseしているDBIx::Class::StartupCheckでは

BEGIN {

    { package TestRHBug; use overload bool => sub { 0 } }

    sub _has_bug_34925 {
	my %thing;
	my $r1 = \%thing;
	my $r2 = \%thing;
	bless $r1 => 'TestRHBug';
	return !!$r2;
    }

    sub _possibly_has_bad_overload_performance {
	return $] < 5.008009 && ! _has_bug_34925();
    }

    unless ($ENV{DBIC_NO_WARN_BAD_PERL}) {
	if (_possibly_has_bad_overload_performance()) {
...snip...

と、こんなことをしてるわけです。
つまり、warnningを止めたければ、環境変数を設定するか、5.8.8でoverloadのバグが存在したままである必要があるわけです。
うーーーーーん。

なので、結論としては
  • DBICを使わない人はそのまま。
  • DBICは使うけど、warningsは環境変数で設定する or 気にしない人もそのまま。
  • DBICは使うけど、warnigsは鬱陶しいしoverloadのバグなんかどーでもいい人はSPECファイルから
    Patch27509
    Patch27512
    に加えて
    Patch31996
    Patch32018
    Patch32019
    Patch32025
    をはずしてrpmbuildする。

といった感じでしょうか。
あ、perlパッケージをアップグレードした時はErrnoとScalar::Utilのforce installも忘れずにね。

ちなみに僕はDBIx::Class.pmから use DBIx::Class::StartupCheck;をはずしました。(ぇ

Image::Seekは結構面白いモジュールだなーなんて思ってたらyusukebeさんがYokohama.pmのLTでドンピシャのタイミングで紹介されてた(残念ながら行けなかったですが...)ので、ちょこちょこっと作ってみました。

Favicon::Gallery

Favicon::Gallery

入力されたURLからfaviconを持ってきて登録されている中から似たfaviconを探すだけの簡単なお仕事です。
あらかじめAlexaのトップ500のサイトから適当に入れてみました。

ちなみにImage::Seekはimgseekの実装でHaar waveletを用いて相関を求めてます。
精度に関しては?って感じではありますが、まーお遊びなので。


Kazuho@Cybozu Labs: フレンド・タイムライン処理の原理と実践

奥さん本人の中でブームが去った感もあるRDBMSで実現するフレンド・タイムライン処理ですが、そういえばDBICで使ってみたのを思い出したので晒してみます。

要はDBICからストアドプロシージャの叩き方を知りたかっただけなんですけどね。

パッケージ名はWebインターフェースはどーせCatalystで作るでしょってことでCatalyst + Twitter = Catatter…って安直なネーミングですね。

記事中ではプッシュ型とプル型が紹介されているのですが、データ量やfollow, removeの際のコストとか考えたらプル型の方が好みかなってことでプル型を採用してみました。

また、基本的にスキーマやストアドプロシージャはオリジナルと同じですが、DBICでPKをマルチカラムにするとめんどっちーのでサロゲートキーを追加したりしてます。

CREATE TABLE user (
    id int(10) unsigned NOT NULL AUTO_INCREMENT,
    screen_name varchar(255) NOT NULL,
    PRIMARY KEY (id)
) ENGINE=innodb;

CREATE TABLE message (
    id int(10) unsigned NOT NULL AUTO_INCREMENT,
    user_id int (10) unsigned NOT NULL,
    body varchar(255) NOT NULL,
    PRIMARY KEY (id),
    KEY userid_id_id(user_id, id)
) ENGINE=innodb;

CREATE TABLE follower (
    id int(10) unsigned NOT NULL AUTO_INCREMENT,
    user_id int (10) unsigned NOT NULL,
    follower_id int (10) unsigned NOT NULL,
    PRIMARY KEY (id),
    UNIQUE (user_id, follower_id),
    KEY user_id_follower_id (user_id, follower_id),
    KEY follower_id(follower_id)
) ENGINE=innodb;

DELIMITER //
CREATE PROCEDURE fetch_timeline_ids (IN uid int unsigned)
BEGIN
  DECLARE fid,maxid int unsigned;
  DECLARE done int DEFAULT 0;
  DECLARE fid_maxid_cur CURSOR FOR
    SELECT follower_id,(
      SELECT id FROM message WHERE user_id=follower.follower_id
      ORDER BY user_id DESC,id DESC LIMIT 1) AS max_id
    FROM follower WHERE user_id=uid ORDER BY max_id DESC LIMIT 20;
  DECLARE CONTINUE HANDLER FOR NOT FOUND SET done=1;
  CREATE TEMPORARY TABLE IF NOT EXISTS fetch_timeline_tt (
    id int unsigned NOT NULL PRIMARY KEY
  ) ENGINE=heap DEFAULT CHARSET=utf8;
  DELETE FROM fetch_timeline_tt;
  OPEN fid_maxid_cur;
  REPEAT
    FETCH fid_maxid_cur INTO fid,maxid;
    IF NOT done THEN
      INSERT INTO fetch_timeline_tt
        SELECT id FROM message WHERE user_id=fid
        ORDER BY id DESC LIMIT 20;
    END IF;
  UNTIL done END REPEAT;
  CLOSE fid_maxid_cur;
END;

CREATE PROCEDURE build_max_ids_of_followers (IN uid int unsigned,IN max_id int unsigned)
BEGIN
  DECLARE fid int unsigned;
  DECLARE done int DEFAULT 0;
  DECLARE fcur CURSOR FOR
    SELECT follower_id FROM follower WHERE user_id=uid;
  DECLARE CONTINUE HANDLER FOR NOT FOUND SET done=1;
  CREATE TEMPORARY TABLE IF NOT EXISTS max_ids_of_followers (
    user_id int unsigned NOT NULL,
    max_id int unsigned NOT NULL
  ) ENGINE=heap DEFAULT CHARSET=utf8;
  DELETE FROM max_ids_of_followers;
  OPEN fcur;
  REPEAT
    FETCH fcur INTO fid;
    IF NOT done THEN
      INSERT INTO max_ids_of_followers SELECT fid,max(id) AS m FROM message
        WHERE user_id=fid AND id<max_id HAVING NOT ISNULL(m);
    END IF;
  UNTIL done END REPEAT;
  CLOSE fcur;
END;

CREATE PROCEDURE fetch_timeline_ids2 (IN uid int unsigned,IN maxid int unsigned)
BEGIN
  DECLARE fid,fmaxid int unsigned;
  DECLARE done int DEFAULT 0;
  DECLARE fid_maxid_cur CURSOR FOR
    SELECT user_id,max_id FROM max_ids_of_followers
    ORDER BY max_id DESC LIMIT 20;
  DECLARE CONTINUE HANDLER FOR NOT FOUND SET done=1;
  CREATE TEMPORARY TABLE IF NOT EXISTS fetch_timeline_tt (
    id int unsigned NOT NULL PRIMARY KEY
  ) ENGINE=heap DEFAULT CHARSET=utf8;
  DELETE FROM fetch_timeline_tt;
  CALL build_max_ids_of_followers(uid,maxid);
  OPEN fid_maxid_cur;
  REPEAT
    FETCH fid_maxid_cur INTO fid,fmaxid;
    IF NOT done THEN
      INSERT INTO fetch_timeline_tt
        SELECT id FROM message
        WHERE user_id=fid AND id<=fmaxid
        ORDER BY id DESC LIMIT 20;
    END IF;
  UNTIL done END REPEAT;
  CLOSE fid_maxid_cur;
END;
//
Catatter::Schema
package Catatter::Schema;

use strict;
use warnings;

use base 'DBIx::Class::Schema';

__PACKAGE__->load_classes;

1;
Catatter::Schema::User
package Catatter::Schema::User;

use strict;
use warnings;

use base 'DBIx::Class';

__PACKAGE__->load_components(
    "Core",
);
__PACKAGE__->table("user");
__PACKAGE__->add_columns(
    "id",
    {   data_type     => "INT",
        default_value => undef,
        is_nullable   => 0,
        size          => 10
    },
    "screen_name",
    {   data_type     => "VARCHAR",
        default_value => "",
        is_nullable   => 0,
        size          => 255
    },
);
__PACKAGE__->set_primary_key("id");
__PACKAGE__->has_many(
    messages => 'Catatter::Schema::Message',
    { 'foreign.user_id' => 'self.id' }
);

sub following_timeline {
    my $self   = shift;
    my $max_id = shift;
    my $cond   = shift;
    my $attrs  = shift || {};

    my $source  = $self->result_source;
    my $storage = $source->storage;
    $storage->dbh_do(
        sub {
            my ( $storage, $dbh, @cols ) = @_;
            if ($max_id) {
                my $sth = $dbh->prepare('Call fetch_timeline_ids2(?, ?)');
                $sth->execute( $self->id, $max_id );
            } else {
                my $sth = $dbh->prepare('Call fetch_timeline_ids(?)');
                $sth->execute( $self->id );
            }
        }
    );

    $source->schema->resultset('Message')->search(
        {%$cond},
        {   join => [qw/messages/],
            %$attrs
        }
    );
}
1;
Catatter::Schema::Message
package Catatter::Schema::Message;

use strict;
use warnings;

use base 'DBIx::Class';

__PACKAGE__->load_components(
    "Core",
);
__PACKAGE__->table("message");
__PACKAGE__->add_columns(
  "id",
  { data_type => "INT", default_value => undef, is_nullable => 0, size => 10 },
  "user_id",
  { data_type => "INT", default_value => "", is_nullable => 0, size => 10 },
  "body",
  { data_type => "VARCHAR", default_value => "", is_nullable => 0, size => 255 },
);
__PACKAGE__->set_primary_key("id");
__PACKAGE__->belongs_to(user => 'Catatter::Schema::User', {'foreign.id' => 'self.user_id'});
__PACKAGE__->belongs_to(timeline => 'Catatter::Schema::FetchTimelineTt', {'foreign.id' => 'self.id'});

1;
Catatter::Schema::Follower
package Catatter::Schema::Follower;

use strict;
use warnings;

use base 'DBIx::Class';

__PACKAGE__->load_components(
    "Core",
);
__PACKAGE__->table("follower");
__PACKAGE__->add_columns(
  "id",
  { data_type => "INT", default_value => undef, is_nullable => 0, size => 10 },
  "user_id",
  { data_type => "INT", default_value => "", is_nullable => 0, size => 10 },
  "follower_id",
  { data_type => "INT", default_value => "", is_nullable => 0, size => 10 },
);
__PACKAGE__->set_primary_key("id");
__PACKAGE__->add_unique_constraint("user_id", ["user_id", "follower_id"]);
__PACKAGE__->belongs_to(user => 'Catatter::Schema::User', {'foreign.id' => 'self.user_id'});
__PACKAGE__->belongs_to(follower => 'Catatter::Schema::Userr', {'foreign.id' => 'self.follower_id'});

1;
Catatter::Schema::FetchTimelineTt
package Catatter::Schema::FetchTimelineTt;

use strict;
use warnings;

use base 'DBIx::Class';

__PACKAGE__->load_components(
    "Core",
);
__PACKAGE__->table("fetch_timeline_tt");
__PACKAGE__->add_columns(
  "id",
  { data_type => "INT", default_value => undef, is_nullable => 0, size => 10 },
);
__PACKAGE__->set_primary_key("id");
__PACKAGE__->belongs_to(message => 'Catatter::Schema::Message', {'foreign.id' => 'self.id'});

1;
で使い方は
use Catatter::Schema;

my $schema = Catatter::Schema->connect('dbi:mysql:catetter', 'user', 'pass');
my $user = $schema->resultset('User')->find(1);
my $timeline = $user->following_timeline(
    undef, 
    {}, 
    {order_by => 'me.id DESC', rows => 20}
);
my $minid;
while (my $message = $timeline->next) {
    print $message->user->screen_name . ': ' . $message->body . "\n";
    $minid = $message->id;
}
こんな感じ。 ただ、pageは効かないので次のページを取るには現在のresultsetの一番小さいidを渡してやる必要があります。
my $timeline = $user->following_timeline(
    $minid, 
    {}, 
    {order_by => 'me.id DESC', rows => 20}
);
ちなみに自分のタイムラインは
my $timeline = $user->messages(
    {}, 
    {order_by => 'me.id DESC', rows => 20}
);
で取れます。

結論から言うと、DBICから綺麗にストアドプロシージャを叩く方法がわからず生のDBHを叩くというどーなんだ?的な解決方法になってます。

全体的に無理やり感がありますが、まーこんな感じでもできるよって感じで。

プロフィール

このアーカイブについて

このページには、過去に書かれたブログ記事のうちPerlカテゴリに属しているものが含まれています。

前のカテゴリはPCです。

最近のコンテンツはインデックスページで見られます。過去に書かれたものはアーカイブのページで見られます。