Image::Seekは結構面白いモジュールだなーなんて思ってたらyusukebeさんがYokohama.pmのLTでドンピシャのタイミングで紹介されてた(残念ながら行けなかったですが...)ので、ちょこちょこっと作ってみました。
入力された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-users.jp - 日本のPerlユーザのためのハブサイト
以前より Shibuya.pm 界隈では、初心者や複雑な Perl の話題をキャッチアップ出来ない Perl 利用者をどうすくい上げるか、という議論を盛んに行っておりました。 Schwern の言う通り Perl で検索してもなかなかいい情報にたどり着けなかったりと、それは酷い現状をどうにかしたいという思いは YAPC::Asia 2008 のスピーカー陣に共通するものであると思っています。
Yappo++
前のエントリーでも紹介したSchwernのPerl Is unDeadに対するYappoスタンダードの答えがこれ。すばらしい。
前々からmiyagawaさんを初めとする最前線を張っている人たちと、レンタルサーバーで掲示板をインストールするのに四苦八苦してる人たちの間の隔たりがすごいなーとか思ってたので、その辺を埋めてくれるサイトに成長してくれたらいいなーって思います。
後は飽きずに継続させることが重要だなーって思うわけです。
っつーか、何か知らんけどコアメンバー候補に挙がってるので僕も何かしらアクションを起こさないとね。
人選の基準が「オヤジ」って気がするのは被害妄想ってことにしておこう。
品質保証だとか、リファクタリング時の精神安定剤だとか言われてるテストですが、実はもう一つ重要な使い道があります。
それは実践的なドキュメントとしてです。
まぁ、もともとTDD(テスト駆動開発)なんかだと仕様の代わりとして扱われるのだから、当たり前って言えば当たり前なんですけどね。
CPANモジュールには大体POD(Perl Old Document)が付いててSYNOPSIS(使い方)が最初のほうにドンと書いてあるのですが、大雑把過ぎたり機能のごく一部だけだったりでちょっと物足りないという貴兄や、英語で長々と説明されるよりも実際の使われ方見たほうが早いっていう貴兄にはテストを眺めるのがもってこいです。
Perlモジュールのテストを見るにはアーカイブを展開してt/以下をのぞいてみてください。まともなモジュールなら山ほどテストが見つかるはずです。運がよければ探してる機能が見つかるはず。
実際のテストを見るには、アーカイブを持ってきて展開して見るのもいいけど、cpanシェルならもっと簡単にできます。
[hide@localhost hide]# cpan ... cpan[1]> look Moose ... [hide@localhost Moose-0.44-4RfUBu]#
こんな感じでパッケージが展開されたビルドディレクトリに入れるので後はt/以下を探検するといいと思います。
ちなみにMooseでは
t/000_recipes
t/200_examples
など見ると初歩的な使い方がたくさん載ってていいと思いますョ。
YAPCでのMichael Schwernのトーク、"perl is unded"を聞いて、Perlは確かに死んじゃいないけど新しい人材は必要だよねって思ったわけです。
で、今年のYAPCには会社の若い子たちを誘って行ったんだけど、口を揃えて言うのが難しい上にさらに英語だからたまらんと。
気持ちは分からんでもないんですよ。僕もあまり得意な方じゃないし。
で、未熟な僕でも何かできないかなーと思ったのがpod(マニュアルね)の翻訳。
しかもMooseなら、敬遠されがちなPerlのややこしいオブジェクト指向プログラミングを分かりやすく書けるので、他の言語の人にも受け入れられやすいかなーと。
まぁ単に今はやりだってだけだけどね(Yapooさん曰く来年にはないらしいけど)。
で、やったもん勝ちってことで、つたない翻訳だけどとっとと始めちゃいました。
とりあえず、日本人が多いってことでcodereposに上げてます。
http://coderepos.org/share/browser/docs/moose-ja
本家の方には話を通してあって、近いうちに本家のtrunkにも放り込んでいくのでじゃんじゃん添削・追記してください。
tokuhiromさんやYappoさんは日本独自でCookbook書いてくれるそうなので、そっちも乞うご期待。
Perlは怖くないよ。楽しいよ。
今年もYAPC::Asiaに参加してきたよ。
今年は前夜祭からHackathonまで猛烈に堪能してきました。
各セッションの感想は山ほど上がってると思うので個人的な感想を書くよ。
去年辺りから積極的に勉強会やカンファレンスで周りに声をかけるようになったせいで、今年は顔見知りも多くなり、また違った空気を楽しめました。
タバコミニケーションではYusukebeさんとオッパイDetect論をしたり、弾さんとSQLをdisったり、飲み会ではオヤジクラスタのZigorouさんやcharsbarさんと新橋的なノリで話したりと本編以外のとこでもかなり楽しませてもらいました。
あと、毎度のこと感動するのがスタッフのホスタビリティ。takesakoさんを初めとするスタッフの方々には足を向けて寝れないっす。本当にありがとうございました。
typesterさんに誘ってもらったHackathonでは酒も一滴も飲まずに12時間くらいひたすらコードを書きまくっててあまり会話には参加できなかったのがちょっと残念。
明け方にMooseでちょっと詰ってnothingmuchに質問したら、あっという間に解決方法を書いてくれて超感動した。おまけにcommitbitまでくれた。っていうかnothingmuchは本当にいいやつ。
来年までの課題はもうちょっとまともに英会話できるようにしておくこと。
来年はネタがあればSpeakerで是非参加してみたいな。
オマケ：
懇親会のクジで当たったモバ指的なナニか。
使い道が良く分からないけどありがとうございます。
AOPが騒がれ始めた辺りでJavaを辞めたので、AOPをよくわかってない。
で、AOPに関する記事を斜め読みしてたら「Separation of Concerns」ってのと「Crosscutting Concern」ってのが出てきたのでMooseでやってみた。
良くありがちな銀行口座クラスをMooseで作ってみる。
package BankAccount;
use Moose;
has 'balance' => (is => 'rw', isa => 'Int', default => 0);
sub deposit {
my ( $self, $amount ) = @_;
$self->balance( $self->balance + $amount );
}
sub withdraw {
my ( $self, $amount ) = @_;
$self->balance >= $amount
? $self->balance( $self->balance - $amount )
: confess 'account overdrawn';
1;
基本的なMooseによるクラス定義。一応説明しておくと
has 'balance' => (is => 'rw', isa => 'Int', default => 0);
balance(残高)という属性を持っていて$self->balanceがgetter。
$self->balance($amount)がsetter。
型チェックが行われてIntのみ受け付ける。
デフォルトはは0。
メソッドは二つで、depositが入金でwithdrawが出金。
これは普通のPerl OOのメソッドと同じ。
このクラスは普通に
my $account = BankAccount->new; warn $account->balance; $account->deposit(10000); warn $account->balance;
みたいに使えて結果は
0 10000
で、ここに要件として
「depositの後にいくら入金されたかログとして表示しなさい」
ってのが追加されたとする。
普通は
sub deposit {
my ( $self, $amount ) = @_;
$self->balance( $self->balance + $amount );
warn "log: deposited $amount ";
}
とかやるんだけど、これだと
1. 本質的な処理(ここで言うと入金された金額を残高に足す)って処理に本来関係ない処理(いくら入金されたか表示する)が含まれて見通し悪い。
2. 更に、ロギングとかって他にも使い道あるんだからまとめたい。
1.のようにコードの関心事を切り分けることをAOPでは「関心事の分離(Separation of Concerns)」っていう。
2.のようにいくつものクラスにまたがって利用される関心事をAOPでは「横断的な関心事(Crosscutting Concern)」っていう。
これをMooseで実装するにはどうするかというとMoose::Roleを使う。RoleはJavaで言うとこのInterfaceに実装を加えられるようなもの。
package BankAccount::Role::Logable;
use Moose::Role;
requires qw(deposit withdraw);
after 'deposit' => sub {
my ($self, $amount) = @_;
warn "log: deposited $amount ";
};
1;
requires qw(deposit withdraw);
は、このRoleを使うにはdepositメソッドととwithdrawメソッドを実装する必要がある、という意味で、
で、
after 'deposit' => sub {...
は、depositメソッドを呼ばれた後に以下のコードを実行するって意味。
で、
package BankAccount;
use Moose;
with 'BankAccount::Role::Logable';
has 'balance' => (is => 'rw', isa => 'Int', default => 0);
sub deposit {
my ( $self, $amount ) = @_;
$self->balance( $self->balance + $amount );
}
sub withdraw {
my ( $self, $amount ) = @_;
$self->balance >= $amount
? $self->balance( $self->balance - $amount )
: confess 'account overdrawn';
1;
ってする。
with 'BankAccount::Role::Logable';
は、BankAccount::Role::Logableを使うよっていう宣言。Javaで言うとimplementsみたいなもん。これをすることによってRoleで宣言されているメソッドを実装する必要が出てくる。
で、さっきのを実行すると
0 10000 log: deposited 10000
って見事ログが表示されてdepositメソッドを変更することなく要件は満たした。
つまり関心事を分離したことによって本来の関心事(Core Concern)に変更を加えることなく新たな関心事を付け加えることが出来るのでコードが見やすい。
ちなみにafterの他に当然beforeもあって、もう一つaroundってのもある。
「出金の前後にログを表示しなさい」
ってな要件が加わったらBankAccount::Role::Loggableに
around 'withdraw' => sub {
my ($next, $self, $amount) = @_;
print "log: before withdraw $amount:\n";
$next->($amount);
print "log: after withdraw $amount: \n";
}
的なことを加えればいい。BankAccountには何も変更なし。
ちょっといい例が思いつかないけど、同じようにBankAccount::Role::Loggableをwithしてdepositとwithdrawを実装したら同じようにログを吐いてくれる。
とにかく、こーゆーことをすることによってコードは見やすくなり、クラスの再利用しやすくなる…って理解してる。
今、超熱いMoose始めたよ。
で、Moose理解するにはClass::MOP理解しなきゃいけなくて、Class::MOP理解するにはMOP理解しなきゃいけないので、ircでえろい人たちに色々教わったのでメモ。
ロジックを直接コーディングするのではなく、あるパターンをもったロジックを生成する高位ロジックによってプログラミングを行う方法んで、これを実現するために必要なのがメタクラスとMOP。
MOP(メタオブジェクトプロトコル)
メタクラスを通してオブジェクトシステムへアクセスするAPI
メタクラス
クラスの振る舞いを定義したクラスでイントロスペクション(introspection)とインターセッション(itercession)を備える
イントロスペクション
オブジェクトの属性を得る能力 ex) 何のクラスを継承しているかとか、何のメソッドを持ってるかとか
インターセッション
オブジェクトの振る舞いに変更を加える能力 ex) 親クラスを変更するとか、メソッドを追加するとか。
で、Class::MOPはPerl 5のオブジェクトシステムに対してのMOPを提供してくれるモジュール。
Class::MOPには大きく分けて4つのモジュールでプロトコルが提供されてる。
Class::MOP::Class - クラスに対するプロトコル
Class::MOP::Attribute - アトリビュートに対するプロトコル
Class::MOP::Method - メソッドに対するプロトコル
Class::MOP::Instance - クラスのインスタンス生成に対するプロトコル
で、これらを使うとこんな風に書けちゃう。
use strict;
use warnings;
use Class::MOP;
{
package Hoge;
use metaclass;
}
my $meta = Hoge->meta;
my $meth_hello = Class::MOP::Method->wrap( sub { print "hello\n"; } );
my $attr_foo = Class::MOP::Attribute->new( '$foo' => ( accessor => 'foo' ) );
my $attr_bar = Class::MOP::Attribute->new( '$bar' => ( accessor => 'bar' ) );
my $hoge = Class::MOP::Instance->new($meta)->create_instance;
$meta->add_method( 'hello' => $meth_hello );
$meta->add_attribute($attr_foo);
$hoge->hello; # hello
$hoge->foo('FOO');
warn $hoge->foo; # FOO
eval { warn $hoge->bar; };
warn $@; # Can't locate object method "bar" via package "Hoge"
$meta->add_attribute($attr_bar);
$hoge->bar('BAR');
warn $hoge->bar; # BAR
で、MooseはClass::MOPをラップして使いやすくしてくれる＋α的なモジュール。
use strict;
use warnings;
{
package Hoge;
use Moose;
has 'foo' => (is => 'rw');
sub hello {
my $self = shift;
print "hello\n";
}
}
my $hoge = Hoge->new;
$hoge->hello; # hello
$hoge->foo('FOO');
warn $hoge->foo; # FOO
もちろんメタクラスにアクセスできるので
$hoge->meta->add_attribute('$bar', accessor => 'bar');
$hoge->bar('BAR');
warn $hoge->bar; # BAR
てなこともできる。
すっげー便利。
参考:
Class::MOP - A Meta Object Protocol for Perl 5 - search.cpan.org
Moose - A postmodern object system for Perl 5 - search.cpan.org
meta-object-protocol
meta object protocol について考えてみる - TokuLog 改め だまってコードを書けよハゲ
Soozy Conference #4あたりからtokuhiromさんが声を大にして言っているCatalystのNEXT気持ち悪い説。
酒の席でこの話になるたびに奥の座敷から大声で呼び出されるCatalystのNEXT気持ち悪い説。
気を抜いてDBICを褒めるとClass::C3も同じじゃねーかとDisられるCatalystのNEXT気持ち悪い説。
僕も激しく同意。なのでちょっとまとめておく。
NEXTを使う場合、こんな感じかと。
use strict;
use warnings;
use NEXT;
package PluginA;
sub foo {
print "A";
shift->NEXT::foo;
}
package PluginB;
sub foo {
print "B";
shift->NEXT::foo;
}
package Object;
use base qw/PluginA PluginB/;
package main;
Object->foo;
実行したら
AB
ところがPluginAの作者が気まぐれに
package PluginA;
sub foo {
shift->NEXT::foo;
print "A";
}
こんなことしたら、当然結果は変わってきます。
BA
使う側としては継承順に呼ばれることを期待しているのに、思ったとおりに動かない。
つまり、使う側がプラグインの中身の挙動まで気を使わなければいけない。
これはClass::C3になっても同じ。
じゃあどうするか。
Componentなノリでメソッドを生やす形でメソッド追加、Pluginなノリでhookポイントに登録してメソッド拡張がよさげ。
というわけでClass::ComponentでOkina！
応援してます！
DBIC::Inflateを作ってこんなコードを作ってたのに動かなかった。
__PACKAGE__->inflate_column(
name => {
inflate => sub {
my ( $value, $obj ) = @_;
warn "inflate name\n";
return "inflate: $value";
},
deflate => sub {
my ( $value, $obj ) = @_;
warn "deflate name\n";
return "deflate: $value";
},
}
);
inflateは動くけどdeflateは動かない。
で、よくよく調べてみました。
というかDBIx::Class::InflateColumnのpod読みました。
It will handle all types of references except scalar references. It will not handle scalar values, these are ignored and thus passed through to SQL::Abstract. This is to allow setting raw values to "just work". Scalar references are passed through to the database to deal with, to allow such settings as \'year + 1' and \'DEFAULT' to work.
つまりscalarは無視するよと。
さらに
If you want to filter plain scalar values and replace them with something else, contribute a filtering component.
もしscalar valueをフィルタリングしたり置換したいならフィルタリングコンポーネントとして作りなさいよと。
恥ずかしながら知りませんでした。
実際ソースを見てみると
sub _deflated_column {
my ($self, $col, $value) = @_;
# return $value unless ref $value && blessed($value); # If it's not an object, don't touch it
## Leave scalar refs (ala SQL::Abstract literal SQL), untouched, deflate all other refs
return $value unless (ref $value && ref($value) ne 'SCALAR');
... snip ...
てな感じで、いきなりreturnされてます。
_inflated_columnではこのような処理をされていないので、ちょっと混乱しました。
これでDBIx::Class::UTF8ColumnsやDBIx::Class::DigestColumnsがInflateColumnsを使っていない理由がわかりました。
WARNING: DBIx::Class::StartupCheck: This version of Perl is likely to exhibit extremely slow performance for certain critical operations. Please consider recompiling Perl. For more information, see https://bugzilla.redhat.com/show_bug.cgi?id=196836 and/or http://lists.scsys.co.uk/pipermail/dbix-class/2007-October/005119.html. You can suppress this message by setting DBIC_NO_WARN_BAD_PERL=1 in your environment.
CentOSでPerlのバージョンとDBIx::Classのバージョンを上げたらDBIx::Classを使うたびにこんなエラーが出るようになりました。
kazeburoさんやYappoさんが言ってたRed Hat系のディストリビューションのPerlのパッケージにはoverloadされたクラスをblessするとリファレンスを全て検索するパッチがあてられていて遅いので注意してねって感じですか。
覗いてみるとDBIx::ClassでuseしてるDBIx::Class::StartupCheckのBEGINブロックで
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...
こんな感じでテストしてお節介にご丁寧にメッセージを出してくれてます。0.08008からみたいですね。
メッセージを止めるにはメッセージにあるとおり、環境変数DBIC_NO_WARN_BAD_PERLに値をセットすればオッケー。
とは言え、根本的解決にはならないのでkazeburoさんの言うとおりパッチはずしてrpmbuildしてインストールしました。Feodoraでは8で解決したらしいですがCentOSではまだ解決してないんですね。
Perlのバージョンを上げたらScalar::Utilをforce installしないとWeak references are not implemented in the version of perlになるので要注意です。
というわけでCatalyst + Web::Scraperを使ってamazletのCISCO RECORDS版ciscoletを作ってみました。Web::Scraper++
こんなHTMLを作ってくれます。
完全にamazletのぱくりです。ごめんなさい。
CISCOにアフィリエイトの仕組みがないので何のメリットもありません。
多分ボクしか使いません。
Shibuya.pm Teck Talk #8に参加させていただきました。
というわけで、出遅れ感てんこ盛りなのでかいつまんで感想です。
(以下表題は敬称略で)
Class::Component (Yappo)
Class::Componentは使いこなせないまま投げ出したのですが、今回のプレゼンを見てまた触りたくなりました。喫煙所でDanさんの「あのサンプルだとC::Componentのありがたみないねー」のツッコミに対して「サンプルですから」とつぶやいたYappoさんの目が印象的でした。
Practical Web Scraping with Web::Scraper (miyagawa)
ちょうどのめり込んだ後だったのでわかりやすく聞けました。CUIは知らなかった。便利そうなので使ってみたいと思います。
Perlで入門テキストマイニング (Tatsuwo)
あーゆーアルゴリズム系な話大好き。形態素解析大好き。なので大変参考になりました。
６年前に作ったプログラムにテストコードを書きました ^^); ～～ テスト駆動開発の薦め (Yuumi)
「テストファーストは宗教です」とか言う声がどこかから聞こえてましたが、それはさて置きボクもテストほとんど書いてません。おっしゃるとおり後々楽になりたいので書きたいので、DBやネットワーク周りなんかを考慮したテストの書き方Tipsをこの次は期待しています。
Flash with perl (typester)
以前、Flashを使ったファイルアップロードやSocketを使ったチャットなんかを作ったことがあるので、perlの話がなくても楽しかったです。それにしても、Flashアップローダーのデメリットが知りたい。
続イメージファイト (TAKESAKO)
個人的に(っていうかみんな)毎回楽しみな竹迫さんのプレゼンはやっぱりステキでした。ブラウザの挙動というかバグというかを逆手に取った判別方法は使えるかどうか別にして新しかったです。それにしてもlynxまでちゃんと調べる辺りが・・・
リビドー駆動開発によるPlaggerとCatalystを使った(Mashup)サイト開発 (yusukebe)
今回、一番うけたプレゼン。技術的な話うんぬんはどーでもいいです。あのパワーは見習いたい。
というわけで、他にもたくさんのお話を聞けましたが、当方の勉強不足と経験不足で理解が足らなかったことも多々あったのが、ちょっと悔しかったです。特に、Gungho, Swarmage, POE::Component::MDBAによるデータ収集 (牧)やMogileFSのplugin拡張 (ZIGOROu)辺りは避け続けて来たけど、そろそろやらんといかんところなので今後の課題としたいと思います。
あと、関係ないとこで今回はustで顔出ししてることもあり、たくさん挨拶したいなと思ったのですが、照れ屋さんなのと時間がなくてtypesterさんだけ挨拶になってしまいました。この辺も反省。
あと、typesterさんに「中日ほぼ2位おめでとうございます。」言い忘れたのも反省。
とにもかくにも、関係者の皆様ご苦労様でした！
以前書いた Web::ScraperでCISCO RECORDSをスクレーピングという記事に対してBig Sky :: Web::Scraper 0.15で何が変わったのか...とおまけでWeb::Scraper 0.15での添削例として扱ってもらったので、さらにリプライ。
treeを壊さずやるとすれば、TextNodeを参照するのがいいかと思います。 例えば、XPathのnode()を使い、番号指定で取得します。だた現状のWeb::ScraperではTextNodeはショートカットで参照出来ませんので、以下のようにstring_valueを返すように手を加えると上手く行きます。問題が一つ。 添削してくださったパッチだと
process '//li/node()[4]', 'title' => sub {$_->string_value;};
となっているのですが、4番目とは限らないんです。
たとえば、
http://www.cisco-records.co.jp/html/item/004/010/item393180.html
は何曲か試聴サンプルがないために、この処理だと取得できないです。
process '//p[@class="de_star"]/node()[2]', 'star' => sub {$_->string_value;};
こちらは例外がないのでばっちり動きます。
更にさっきアップされていた0.16では
0.16 Tue Sep 18 04:48:47 PDT 2007
- Support 'RAW' and 'TEXT' for TextNode object
ということなので
process '//p[@class="de_star"]/node()[2]', 'star' => 'TEXT';
でも、大丈夫でした。
あと、相対URLの展開ですが、今のところコールバック関数内では展開されないようです。
なので、添削していただいたものでは意図するように動かないようです。
ただ、こっちは深く追っていないので定かではありません。つっこみ歓迎です。
ともかく、フィードバックありがとうございました。
大変勉強になりました。
いまさらWeb::Scraperを使ってみました。
使うネタがなかったのがスルーし続けた一番の理由だったのですが、それではいけないと思い、CISCO RECORDSの商品情報を取得するスクリプトという、僕以外誰も興味がないスクリプトを書いてみました。
#!/usr/bin/perl
use strict;
use warnings;
use Web::Scraper;
use URI;
use YAML;
use Data::Dumper;
my $uri = shift;
my %scraper;
$scraper{'link'} = scraper {
process 'a', 'name' => 'TEXT';
process 'a', 'uri' => sub {
return URI->new_abs( $_->attr('href'), $uri )->as_string;
};
result qw/name uri/;
};
$scraper{'genre'} = scraper {
process '//a[1]', 'top' => $scraper{link};
process '//a[2]', 'style' => $scraper{link};
result qw/top style/;
};
$scraper{'track'} = scraper {
process 'li', 'title' => sub {
my $elem = shift;
$elem->find_by_tag_name('span')->delete;
return $elem->as_text;
};
process 'li>a', 'uri' => sub {
return URI->new_abs( $_->attr('href'), $uri )->as_string;
};
result qw/title uri/;
};
$scraper{'item'} = scraper {
process 'td.de_title', 'title' => 'TEXT';
process 'td.de_artist', 'artist' => 'TEXT';
process 'td.nm_jacket>img', 'image' => sub {
return URI->new_abs( $_->attr('src'), $uri )->as_string;
};
process 'td.de_price', 'price' => 'TEXT';
process 'td.de_label>a', 'label' => $scraper{link};
process 'td.de_genre', 'genre' => $scraper{genre};
process 'td[headers="de_format"]', 'format' => 'TEXT';
process 'td[headers="de_release"]', 'release' => 'TEXT';
process 'td[headers="de_country"]', 'country' => 'TEXT';
process 'td[headers="de_sheet"]', 'sheet' => 'TEXT';
process 'td[headers="de_arrival"]', 'arrival' => 'TEXT';
process 'td[headers="de_nomber"]', 'number' => 'TEXT';
process 'p.de_star', 'star' => sub {
my $elem = shift;
$elem->find_by_tag_name('span')->delete;
return $elem->as_text;
};
process 'ul[id="de_sound"]>li', 'tracks[]' => $scraper{track};
result
qw/title artist image price label genre format release release country sheet arrival number star tracks/;
};
my $item = $scraper{'item'}->scrape( URI->new($uri) );
warn Dump $item;
で、ためしに、このページを解析してみると
$ ./cisco_scraper.pl http://www.cisco-records.co.jp/html/item/003/100/item355640.html
---
arrival: 2007/09/03
artist: Capsule
country: JAPAN
format: 12"EP
genre:
style:
name: POP DANCE
uri: http://www.cisco-records.co.jp/list/style.php?qGenre=4&qStyle=128
top:
name: HOUSE
uri: http://www.cisco-records.co.jp/html/genretop/genretop_4.html
image: http://www.cisco-records.co.jp/upimages/003/100/item355640p1.jpg
label:
name: Contemode
uri: http://www.cisco-records.co.jp/html/label/L348/labelL34869_0desc.html
number: 95449
price: '¥1,365'
release: 2007/09/05
sheet: 1
star: ★★★★★
title: Capsule Rmx EP
tracks:
- title: ' Sugarless Girl (Rmx Ver.) '
uri: http://www.cisco-records.co.jp/track/003/100/95449_1.ram
- title: ' CrazEEE Skyhopper (Rmx Ver.) '
uri: http://www.cisco-records.co.jp/track/003/100/95449_2.ram
こんな感じになります。
後はブックマークレットとか作れば今よりもっと簡単にレコードレビューが書けるはず。
Web::Scraper自体はとっても簡単だし、コールバックのおかげでとっても柔軟です。
・・・が、DSLというかXPathがいかんせんめんどっちー。
たとえば
<li><span>1</span>Track 1</li>
というHTMLから"Track1"だけを抽出しようにも
process 'li', 'title' => 'TEXT';
だと
1Track1
なんて結果になるのでそれを回避するために
process 'li', 'title' => sub {
my $elem = shift;
$elem->find_by_tag_name('span')->delete;
return $elem->as_text;
};
なんてことをしてるのですが、もっといい方法があるはず。
この辺のレシピがもっともっとあったら幸せになれそうです。
追記(09/19/2007):
Big Sky :: Web::Scraper 0.15で何が変わったのか...とおまけ
string_valueを使えばスマートになるそうです。thx!
ついでに0.15からはURI->new_absしなくて@hrefで絶対URLを取得できるそうな。便利。
追記(09/19/2007):
さらにリプライ。
参考:DBICでdatetime型のカラムを使うときはInflateColumn::DateTimeを使ってinflate/deflate時に自動的にDateTimeクラスから/に変換してくれてとっても便利ですが、それに慣れっこで検索条件にdatetime型を指定するときは要注意です。
とはいっても、sqlite限定の問題。
sqlite> select id, username, created_on from users;
1|user1|2007-06-14 00:00:00
...
とかいうデータがあったとして
my $dt = DateTime->new(
year => 2007,
month => 6,
day => 14,
time_zone => 'local'
);
my $users = $schema->resultset('Users')
->search( { created_on => $dt} );
まぁ、当然といえば当然で
SELECT me.id, me.username, me.created_on FROM users me WHERE ( created_on = ? ): '2007-06-14T00:00:00'
とかSQLがはかれているので、sqliteではひっかりません。
やっかいなのはmysqlではdatetimeなフォーマットとして認識してくれて動いていたので、ちょっとはまりました。
直接formatterを指定してもいいのですが、ここはInflateColumn::DateTimeの挙動にあわせて
my $parser = $schema->storage->datetime_parser;
my $users = $schema->resultset('Users')
->search( { created_on => $parser->format_datetime($dt)} );
とかやればいいのかなぁと。
DBIx::Class::Storage::DBIDefines (returns) the datetime parser class - currently hardwired to DateTime::Format::MySQL
ということなので、今のところsqliteではDateTime::Format::MySQLを使われてる感じです。
DBICでTwitterのユーザー関係を表してみるってので、どえらい勘違いをしてました。
もごもごは
片想い: A
想われ: B
両想い: C
であってるのですが
Twitterでは
friends: A + C
followers: B + C
ですね。
なのでこのコードだと
もごもごの片想い: $user->favorite_users
もごもごの想われ: $user->follower_users
もごもごの両想い: $user->friend_users
Twitterのfriends: $user->link_users
Twitterのfollowers: $user->linked_users
で取得することになります。
単純なTwitter cloneを作る場合は普通にmany-to-manyでいけるってことです。
追記：
勘違いしてたので別エントリーで補足
Twitterで言うところのfavorites、followers、friends。
もごもごで言うところの片想い、想われ、両想いの関係をDBICで表してみました。
まず関係の定義から。
favorite(片想い):
AがBをお気に入りに入れるとAから見てBはfavoriteな関係(片方向)
follower(想われ):
Bから見てAはfollowerな関係(片方向)
friend(両想い):
Aのお気に入りに入ってるBがAをお気に入りに入れると両方から見てfriendな関係(双方向)
で、テーブル設計ですが、それぞれをテーブルとして持ってもいいのですが、関係を追加するごとにあちこちのテーブルを見なきゃならんので、一個のテーブルで済ましてみました。
要は
user_linksテーブルを使ってusersを自己結合なmany-to-manyの関係にする。
user_links.user_idにはお気に入りに入れるusers.id
user_links.link_user_idにはお気に入りに入れられるusers.id
で、これをDBICのリレーションで表すと
MyApp/Schema.pm
package MyApp::Schema;
use strict;
use warnings;
use base qw/DBIx::Class::Schema::Loader/;
__PACKAGE__->loader_options(
relationships => 1,
debug => 1,
);
1;
MyApp/Schema/UserLinks.pm
package MyApp::Schema::UserLinks;
use strict;
__PACKAGE__->belongs_to(
'user' => 'MyApp::Schema::Users',
'user_id'
);
__PACKAGE__->belongs_to(
'link_user' => 'MyApp::Schema::Users',
'link_user_id'
);
1;
MyApp/Schema/Users.pm
package MyApp::Schema::Users;
use strict;
__PACKAGE__->has_many(
'user_link_users' => 'MyApp::Schema::UserLinks',
'user_id'
);
__PACKAGE__->many_to_many(
'link_users' => 'user_link_users',
'link_user'
);
__PACKAGE__->has_many(
'user_linked_users' => 'MyApp::Schema::UserLinks',
'link_user_id'
);
__PACKAGE__->many_to_many(
'linked_users' => 'user_linked_users',
'user'
);
sub favorite_users {
my ( $self, $cond, $attrs ) = @_;
my $id = $self->id;
my $sub_sql
= "NOT IN (SELECT user_id FROM user_links WHERE link_user_id = $id)";
return $self->link_users(
{ 'link_user_id' => \$sub_sql,
%{ $cond || {} },
},
$attrs
);
}
sub follower_users {
my ( $self, $cond, $attrs ) = @_;
my $id = $self->id;
my $sub_sql
= "NOT IN (SELECT link_user_id FROM user_links WHERE user_id = $id)";
return $self->linked_users(
{ 'user_id' => \$sub_sql,
%{ $cond || {} },
},
$attrs
);
}
sub friend_users {
my ( $self, $cond, $attrs ) = @_;
my $id = $self->id;
my $sub_sql
= "IN (SELECT user_id FROM user_links WHERE link_user_id = $id)";
return $self->link_users(
{ 'link_user_id' => \$sub_sql,
%{ $cond || {} },
},
$attrs
);
}
1;
重要なのはUsersクラスでメソッドは
$user->link_users
自分がお気に入りに入れているユーザー全てを取得
$user->linked_users
自分をお気に入りに入れているユーザー全て取得
これだけだとfriendな関係のユーザーも入ってしまうので別にメソッドを追加します。
$user->favorite_users
link_usersで自分をお気に入りに入れていないユーザー
$user->follower_users
linked_usersで自分がお気に入りに入れていないユーザー
$user->friend_users
link_usersで自分をお気に入りに入れているユーザー
many-to-manyなリレーションを作ると
$user->add_to_link_users($user)
$user->add_to_linked_users($user)
のメソッドが自動的に作成されるので関係の追加にはこれを使うといいかも。
で、実際に使うにはこんな感じ
use strict;
use warnings;
use MyApp::Schema;
# userを3人作成
my $schema = MyApp::Schema->connect('dbi:SQLite:db/myapp.db');
for ( 0 .. 2 ) {
$schema->resultset('Users')->create( { username => "user$_", } );
}
my @users = $schema->resultset('Users')->search( {} );
# user0とuser1はfriend
$users[0]->add_to_link_users( $users[1] );
$users[1]->add_to_link_users( $users[0] );
# user2はuser0のfavorite
# user0はuser2のfollower
$users[0]->add_to_link_users( $users[2] );
# 結果を表示
foreach my $user ( @users ) {
print $user->username;
my $favorites = $user->favorite_users();
print "\tfavarites:\n";
while ( my $favorite = $favorites->next ) {
print "\t\t" . $favorite->username . "\n";
}
my $followers = $user->follower_users;
print "\tfollowers:\n";
while ( my $follower = $followers->next ) {
print "\t\t" . $follower->username . "\n";
}
my $friends = $user->friend_users;
print "\tfriends:\n";
while ( my $friend = $friends->next ) {
print "\t\t" . $friend->username . "\n";
}
}
結果はこんな感じ。
user0 favarites:
user2
followers:
friends:
user1
user1 favarites:
followers:
friends:
user0
user2 favarites:
followers:
user0
friends:
サブクエリを使うのが何ですが、結構お手軽かなと。
要はDBIC::Schema::Loader(0.03010)でSQLiteを使う場合、CREATE TABLEを全部小文字で書くとUNIQUE制約が見つからずにfind_or_createの時に困る件。
こんなテーブルがあった場合、
db/myapp.sqlcreate table users ( id integer not null primary key, username text not null unique, email text not null unique, password text not null );
要はusename, emailにはUNIQUE制約が付いていてpasswordには付いていない場合。
DBIC::Schema::Loaderを使えば自動的にスキーマを作ってくれる。
lib/MyApp/Schema.pm
package MyApp::Schema;
use strict;
use base qw/DBIx::Class::Schema::Loader/;
__PACKAGE__->loader_options(
relationships => 1,
debug => 1,
);
1;
ここでUNIQUE制約を自動的にadd_unique_constraint()してくれると期待しても
MyApp::SchemaUsers->load_components("PK::Auto", "Core");
MyApp::SchemaUsers->table("users");
MyApp::SchemaUsers->add_columns(
"id",
{ data_type => "integer", is_nullable => 0, size => undef },
"username",
{ data_type => "text", is_nullable => 0, size => undef },
"email",
{ data_type => "text", is_nullable => 0, size => undef },
"password",
{ data_type => "text", is_nullable => 0, size => undef },
);
MyApp::SchemaUsers->set_primary_key("id");
add_unique_constraintしてる気配なし。
これはDBIx::Class::Schema::Loader::DBI::SQLiteの_sqlite_parse_tableでUNIQUE制約を探す正規表現にiオプションがついていないのが原因。
create table users ( id integer not null primary key, username text not null UNIQUE, email text not null UNIQUE, password text not null );
なら動くという・・・
MyApp::SchemaUsers->load_components("PK::Auto", "Core");
MyApp::SchemaUsers->table("users");
MyApp::SchemaUsers->add_columns(
"id",
{ data_type => "integer", is_nullable => 0, size => undef },
"username",
{ data_type => "text", is_nullable => 0, size => undef },
"email",
{ data_type => "text", is_nullable => 0, size => undef },
"password",
{ data_type => "text", is_nullable => 0, size => undef },
);
MyApp::SchemaUsers->set_primary_key("id");
MyApp::SchemaUsers->add_unique_constraint("username_unique", ["username"]);
MyApp::SchemaUsers->add_unique_constraint("email_unique", ["email"]);
FOREIGN制約とかはちゃんとiオプションつけてるので何か理由があるんでしょうかね？
追記:
http://lists.scsys.co.uk/pipermail/dbix-class/2007-April/003653.html
というわけでただのバグでそのうち直すそうです。
追記:
http://search.cpan.org/src/BLBLACK/DBIx-Class-Schema-Loader-0.03011/Changes
0.03011でパッチがあたってfixされた模様。
去年に続きperl mogerの祭典YAPC::Asia 2007に行ってきました。
どれもこれも濃い内容だったので、自分のメモ用に気になったのだけ。
関係者の方々お疲れ様でした。
来年も是非よろしくです。
以前、DBIx::Class::DigestColumnsの問題というエントリーでDBIC::DigestColumnsがいまいち使いづらいようなことを書きましたが、今年に入ってアップデートされてちょっと便利になった模様。
ユーザー管理で生パスワードを保存したくない場合には結構便利なコンポーネントです。
create table users (
id integer not null primary key,
username text not null,
password text not null
);
schemaクラスはLoaderにまかせて
package MyApp;
use strict;
use base qw/DBIx::Class::Schema::Loader/;
__PACKAGE__->loader_options(
components => [qw/DigestColumns/],
relationships => 1,
);
1;
resultクラスでDigestColumns周りの設定を追加
package MyApp::Users;
use strict;
__PACKAGE__->add_column(
'password' => {
digest_check_method => 'check_password',
}
);
__PACKAGE__->digestcolumns(
columns => [qw/password/],
algorithm => 'SHA1',
encoding => 'hex',
auto => 1,
dirty => 1,
);
1;
こんな感じのスクリプトを走らせると
use strict;
use warnigs;
use MyApp;
my $schema = MyApp->connect('dbi:SQLite:db/myapp.db');
# Userを追加
my $user = $schema->resultset('Users')->create({
username => 'foo',
password => 'bar',
});
# passwordには 'bar' のハッシュ値が入ってる
print "username: ", $user->username, "\n";
print "password hash: ", $user->password, "\n\n";
# usernameを変更
$user->update({
username => 'baz',
});
# dirty => 1 してあると明示的に指定しない限りハッシュカラムは変更されない
print "username: ", $user->username, "\n";
print "password hash: ", $user->password, "\n\n";
# passwordを変更
$user->update({
password => 'baz',
});
# 明示的に指定するとpasswordには新しい値のハッシュ値が入る
print "username: ", $user->username, "\n";
print "password hash: ", $user->password, "\n\n";
# columnオプションにdigest_check_method => 'check_password'を指定してあると
# 自動的にcheck_passwordメソッドが追加されて評価ができる
print "check password w/ bar: ", $user->check_password('bar'), "\n";
print "check password w/ baz: ", $user->check_password('baz'), "\n";
こんな結果
username: foo password hash: 62cdb7020ff920e5aa642c3d4066950dd1f01f4d username: baz password hash: 62cdb7020ff920e5aa642c3d4066950dd1f01f4d username: baz password hash: bbe960a25ea311d21d40669e93df2003ba9b90a2 check password w/ bar: check password w/ baz: 1ポイントは
最近、またImageMagickをさわる機会があったので、ちまたで人気のPolaroizeと同じことがPerkMagickでできんかとこの辺を参考に試してみました。
手元にまともなImageMagickが使える公開サーバーがなかったのでスクリプトだけ。
Fedora Core 6の
ImageMagick-6.2.8.0-3.fc6.1
ImageMagick-perl-6.2.8.0-3.fc6.1
で試しました。
use strict;
use Image::Magick;
my $input = 'image.jpg';
my $output = 'polaroid.jpg';
my $img = Image::Magick->new;
$img->Read($input);
$img->Border( width => 10, height => 10, color => '#f0f0ff' );
$img->Set( 'background' => 'none');
my $amplitude = $img->Get('columns') * 0.01;
my $wavelength = $img->Get('rows') * 2;
$img->Rotate(90);
$img->Wave( amplitude => $amplitude, wavelength => $wavelength );
$img->Rotate(-90);
my $shadow = $img->Clone;
$shadow->Flop;
$shadow->Colorize( fill => 'grey75', opacity => '100%' );
$shadow->Set( background => 'white' );
$shadow->Border( width => 10, height => 10, color => 'white' );
$shadow->Blur( radius => 0, sigma => 3 );
$shadow->Composite(
image => $img,
x => ( $amplitude / 2 ) * -1,
y => 5,
compose => 'Over'
);
$shadow->Rotate(-5);
$shadow->Trim;
$shadow->Write($output);
結果、これが
こんな感じ。
あまりに古いImageMagickだと動かないかもしれません。
ちなみにImageMagick6.3.2以降だとPolaroidメソッドが追加されていて、こんな面倒なことをしなくても一発でポラロイドなエフェクトをかけられ、しかも文字まで入れれるようです。
が・・・手元ではうまいこと動かなかったので割愛。
誰か試してください。
Catalyst::Plugin::Upload::MIMEを使ってるのですが、このモジュールはMIMEタイプを見つけるのにFile::MimeInfo::Magicを使っています。
use strict; use warnings; use File::MimeInfo::Magic; my $file = 'test'; my $mime = File::MimeInfo::Magic::magic($file); my $ext = File::MimeInfo::Magic::extensions($mime); print "$mime\n"; print "$ext\n";
とかやれば指定されたファイル名に関わらずMIMEタイプやそれに対応する拡張子を取得することができるのですが、JPEGの場合
image/jpeg jpeg
とかなって嫌な感じ。拡張子はjpgにしたいっ。
で、Fedora(他のLinuxパッケージも?)では
/usr/share/mime/globs
のファイルに書かれている順番で配列につっこまれます。
で、デフォルトでは
image/jpeg:*.jpeg image/jpeg:*.jpe image/jpeg:*.jpg
になってるのでこれの順番を
image/jpeg:*.jpg image/jpeg:*.jpeg image/jpeg:*.jpe
に変えればいい。
常識なのかもしれないけど、いつも忘れるのでメモ。
「D-5 出張版：機種依存文字入りのShiftJISを扱う」を読んで大変タイムリーだったので実験して見ました。
はてぶのコメントでmiyagawaさんが
decode("cp932", $buf) でいい気がとおっしゃられているので
こんなんで実験してみました。
JISやEUCを取り扱うのでEncode::Unicode::Japanseを使って見ました。
取り扱うtext.txtは機種依存文字や半角カタカナを含んだこんなファイル。
#!/usr/bin/perl
use strict;
use warnings;
use Encode::Unicode::Japanese;
use Encode qw/encode decode/;
_encode (qw/text.txt shift_jis sjis-utf8.txt utf8/);
_encode (qw/text.txt shift_jis sjis-jis.txt iso-2022-jp/);
_encode (qw/text.txt shift_jis sjis-euc.txt euc-jp/);
_encode (qw/text.txt cp932 cp932-utf8.txt utf8/);
_encode (qw/text.txt cp932 cp932-jis.txt iso-2022-jp/);
_encode (qw/text.txt cp932 cp932-euc.txt euc-jp/);
_encode (qw/text.txt shift_jis sjis-unijp-utf8.txt unijp-utf8/);
_encode (qw/text.txt shift_jis sjis-unijp-jis.txt unijp-jis/);
_encode (qw/text.txt shift_jis sjis-unijp-euc.txt unijp-euc/);
_encode (qw/text.txt cp932 cp932-unijp-utf8.txt unijp-utf8/);
_encode (qw/text.txt cp932 cp932-unijp-jis.txt unijp-jis/);
_encode (qw/text.txt cp932 cp932-unijp-euc.txt unijp-euc/);
sub _encode {
my ($file_in, $enc_in, $file_out, $enc_out) = @_;
open (IN, "$file_in");
open (OUT, ">$file_out");
while (<IN>) {
print OUT encode($enc_out, decode($enc_in, $_));
}
close(OUT);
close(IN);
}
結果は
shift_jis -> utf8 NG
shift_jis -> jis NG
shift_jis -> euc NG
cp932 -> utf8 OK
cp932 -> jis NG
cp932 -> euc NG
shift_jis -> unijp-utf8 NG
shift_jis -> unijp-jis NG
shift_jis -> unijp-euc NG
cp932 -> unijp-utf8 ok
cp932 -> unijp-jis ok
cp932 -> unijp-euc ok
結論としてはutf8を扱うだけだったらcp932->utf8でよくて、eucやjisを使うんだったらEncode::Unicode::Japanese使うとWAVE DASHな問題も解決してくれるので良いかと。