2007年05月15日

DBICのEncodeColumnsとかがResultSet::createで誤動作する件、ほか

実際はDBIC::EncodeColumnsを使っていて気づいたのですが

package Schema::SjisTable;

use strict;
use warnings;
use base 'DBIx::Class';
__PACKAGE__->load_components('EncodeColumns', 'PK::Auto', 'Core');
__PACKAGE__->decode_columns('cp932');

と定義してあるスキーマに
$schema->resultset('SjisTable')->create({ ... })
という感じでinsertするとcp932でDBに格納されるのではなくutf8でDBに格納されてします。
これはUTF8Columnsでも、utf8フラグを立たせてinsertしようとする。

だいぶはまったんだけど、調べて行くうちに理由が分かって来たのでメモします。
DBICのバージョンは最新で0.07006のを元にしています。

insertする時の変な挙動

createが呼ばれた時は、DBIC::Row::insertでinsertするcolumnsを全部持って来てstorageのinsertに処理を渡します。
コードを引用すると

sub insert {
my ($self) = @_;
return $self if $self->in_storage;
$self->{result_source} ||= $self->result_source_instance
if $self->can('result_source_instance');
my $source = $self->{result_source};
$self->throw_exception("No result_source set on this object; can't insert")
unless $source;
#use Data::Dumper; warn Dumper($self);
$source->storage->insert($source->from, { $self->get_columns });
$self->in_storage(1);
$self->{_dirty_columns} = {};
$self->{related_resultsets} = {};
undef $self->{_orig_ident};
return $self;
}
ここで$self->get_columnsが出てくるのですが、これが大元でした。

ようするにinsertすべきcolumnsのデータをget_columnsメソッドで取得します。
このタイミングでget_columnsを呼ぶとUTF8ColumnsやEncodeColumnsのget_columnsを呼び出します。
UTF8Columnsだったらutf8フラグを立ててinsertに(これは問題にならない?)
EncodeColumnsだったらutf8にdecodeしてinsert(encode_columnsを設定していたらencode_columnsの値でencodeしてる)しようとします。
一番上のコードの例ではcp932でDBに入っているデータをutf8にdecodeする設定ですが、cp932にinsertして欲しいのにutf8でinsertすることになっちゃいます。

$row->is_changedの変な挙動


UTF8ColumnsとEncodeColumnsはstore_columnをフックしてutf8フラグを外したりencodeをしてたりしますが、この戻り値が変換後のデータを返してしまう為にレコードの値が下記変わっているかを調べるDBIC::Rowのis_changedメソッドが誤動作をしてしまいます。
レコードの値が変更されたかどうかというのはDBIC::Rowのset_columnでチェックしていて、set_columnで渡された値とset_columnが内部的に呼び出すstore_columnで戻された値を比較して、変更が合った時にis_changedが真になるようにしています。

なので、store_columnをフックする時には入力値と同等の値を返さないと、実際には値の変更が無いのに変更が合ったと誤動作してしまいます。

patch


これら2点の状況を踏まえて意図した通りにEncodeColumnsとUTF8Columnsが動くようにするパッチを書いてみました。
EncodeColumns
--- DBIx/Class/EncodeColumns.pm.orig    2006-11-04 09:35:20.000000000 +0900
+++ DBIx/Class/EncodeColumns.pm 2007-05-15 22:00:27.000000000 +0900
@@ -73,6 +73,7 @@
sub get_columns {
my $self = shift;
my %data = $self->next::method(@_);
+ return %data if $self->{_in_insert};

foreach my $col (keys %data) {

@@ -104,7 +105,16 @@
$value = encode( $self->decode_columns, $value )
if $self->decode_columns;

- return $self->next::method( $column, $value );
+ my $ret = $self->next::method( $column, $value );
+ if( defined $ret ) {
+
+ $ret = decode( $self->decode_columns, $ret )
+ if $self->decode_columns;
+
+ $ret = encode( $self->encode_columns, $ret )
+ if $self->encode_columns;
+ }
+ $ret;
}

=head1 AUTHOR
@@ -118,6 +128,14 @@

=cut

+sub insert {
+ my $self = shift;
+ $self->{_in_insert} = 1;
+ $self->next::method(@_);
+ delete $self->{_in_insert};
+ $self;
+}
+
1;


UTF8Columns
--- DBIx/Class/UTF8Columns.pm.orig      2006-11-17 04:35:35.000000000 +0900
+++ DBIx/Class/UTF8Columns.pm 2007-05-15 22:01:42.000000000 +0900
@@ -87,6 +87,7 @@
sub get_columns {
my $self = shift;
my %data = $self->next::method(@_);
+ return %data if $self->{_in_insert};

foreach my $col (grep { defined $data{$_} } keys %{ $self->_utf8_columns || {} }) {

@@ -117,7 +118,15 @@
}
}

- $self->next::method( $column, $value );
+ my $ret = $self->next::method( $column, $value );
+ if ( $cols and defined $ret and $cols->{$column} ) {
+ if ($] <= 5.008000) {
+ Encode::_utf8_on($ret) unless Encode::is_utf8($ret);
+ } else {
+ utf8::decode($ret) unless utf8::is_utf8($ret);
+ }
+ }
+ $ret;
}

=head1 AUTHOR
@@ -134,5 +143,13 @@

=cut

+sub insert {
+ my $self = shift;
+ $self->{_in_insert} = 1;
+ $self->next::method(@_);
+ delete $self->{_in_insert};
+ $self;
+}
+
1;


ほんとは英語でrtに出すべきなんだけど、うまい英訳ができないorz

FUDだったらどうしよう。

Posted by Yappo at 22:43 | Comments (3) | TrackBack

2007年05月11日

DBIx::Class::Schemaの使い方

亀レスだけどSchema::Loaderネタが流行ってたみたいなので、最近の自分の使い方を。
まぁSoozyつかってるのでmake_schema_atで作られた静的なSchema使ってるんだけども。
自分的にはSchmeaクラスは一切手をつけたく無いので、大部変わった事をしているかも。
若干mfacインスパイアぎみではあるけど。

package Soozy::Plugin::DBIC::AutoSetup;
(略)
sub setup_components {#Catalyst::setup_componentsとほぼ同じ
my $class = shift;

my $schema_bases = Soozy::Component::Loader->find_components(
'',
search => [ $class->base_classname . '::SchemaBase' ],
require => 1
);
for my $base (values %{ $schema_bases }) {
my($to) = $base =~ /^MyApp::SchemaBase::(.+)$/;
$to = "MyApp::Schema::$to";
$to->require or die $@;
no strict 'refs';
unshift @{"$to\::ISA"}, $base;
$to->schemabase_setup($class) if $to->can('schemabase_setup');
}

$class->next::method;
}

って感じのSoozyプラグイン作っておいて
package MyApp::SchemaBase::Database::Table;

use strict;
use warnings;

sub schemabase_setup {
my($class, $c) = @_;
#setup relations and other setup
$class->maight_have( hoge => 'MyApp::Schema::Database::Tb' );
}

sub table {
my($self, @rest) = @_;
my $ret = $self->next::method(@rest);
$self->result_source_instance->resultset_class('MyApp::Schema::Database::Table::_resultset');
$ret;
}

package MyApp::Schema::Database::Table::_resultset;

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

sub search_yapp {
}
1;

みたいなSchemaクラスのベースクラスを別に作っておく感じ。
単純に無理矢理@ISAにぶち込んでもリレーション設定とかの__PACKAGE__->*な処理が出来ないから、schemabase_setupを呼び出して、そこでリレーション設定する感じ。

その戦法でいくとResultSetManagerも使えないから、若干強引にResultSetへのメソッドを生やしている感じ。
そうすると$self->M('Database::Table')->search_yappo();みたいな事が出来る。

ちょっとrequireのタイミングとかが恐いけど、DBIC側のコード見ても今の所問題はなさそうな感じです。

こうやっとく事で開発中は何も気にせずにmake_schema_atしまくれて、在る意味楽です。
スキーマ作り直し放題。


そんな事より、そろそろiYappo真面目にしないと燃え尽きる。

Posted by Yappo at 03:40 | Comments (0) | TrackBack

2007年05月10日

Re: perl - use utf8;

404 Blog Not Found:perl - use utf8;

ちなみに、utf8 pragmaの配下では、リテラルだけではなくシンボル名にもUnicodeを使うことが出来る。
(コード略)
Enjoy!

Dan the Just Another PerlUnicode Hacker


ぼくだったらこう書きます><
#!/usr/bin/perl
use strict;
use warnings;
use utf8;

sub 改行 { "\n" }
sub 国際的なエンコーディングっぽい何か { ':utf8' }
sub 表示するよ { print(@_) };
*普通の出口に = *STDOUT;
sub IO::Handle::ハンドルいぢるよ { binmode shift, shift };

{
package で;
sub で { shift->{呼び出し元}->忘れてよ }

package なの;
sub なの { shift->{呼び出し元}->忘れてよ }

package Ningen;
use overload q{""} => sub {
my $おれ = shift;
my $答えるよ = $おれ->{$おれ->気にしてよ || ''} || '';
$おれ->忘れてよ;
$答えるよ;
};

package お母さん;

sub 生むよ { bless {}, shift->{お父さん} }

package 人間;
{ no strict 'refs'; @{'人間::ISA'} = qw( Ningen ); }

sub を {
my $お父さん = shift;
bless { お父さん => $お父さん }, 'お母さん';
}

sub 名前 {
my $折れ = shift;
die '日本語になってないよ!怒るよ!' if $折れ->気にしてよ;
$折れ->気にしてよ('名前');
$折れ;
}

sub 苗字 {
my $折れ = shift;
die '日本語になってないよ!怒るよ!' if $折れ->気にしてよ;
$折れ->気にしてよ('苗字');
$折れ;
}

sub が {
my $あたし = shift;
return unless $あたし->気にしてよ;
$あたし->{$あたし->気にしてよ} = shift if @_;
return bless { 呼び出し元 => $あたし }, 'で'
if $あたし->気にしてよ eq '苗字';
return bless { 呼び出し元 => $あたし }, 'なの';
}

sub 苗字と名前 {
my $僕 = shift;
die '日本語になってないよ!怒るよ!' if $僕->気にしてよ;
$僕->{苗字} . $僕->{名前};
}

sub 気にしてよ {
my $あーし = shift;
$あーし->{気にしてよ} = shift if @_;
$あーし->{気にしてよ};
}

sub 忘れてよ { delete shift->{気にしてよ} }
}

my $小飼弾 = 人間->を->生むよ;
$小飼弾->苗字->が('弾')->で;
$小飼弾->名前->が('小飼')->なの;

ハンドルいぢるよ 普通の出口に 国際的なエンコーディングっぽい何か;
表示するよ $小飼弾->苗字と名前, 改行;
表示するよ $小飼弾->苗字と名前, 改行;
表示するよ $小飼弾->苗字と名前, 改行;
表示するよ $小飼弾->苗字, 改行;
表示するよ $小飼弾->名前, 改行;
表示するよ $小飼弾->苗字と名前, 改行;
表示するよ $小飼弾->苗字, 改行;
表示するよ $小飼弾->名前, 改行;
表示するよ $小飼弾->苗字と名前, 改行;
表示するよ $小飼弾->苗字, 改行;
表示するよ $小飼弾->名前, 改行;

http://tech.yappo.jp/download/re-dankogai-utf8.pl
use libとかuse overloadとかでUTF8なパッケージが使えなかったりuseできないのがきついすなぁ。

Posted by Yappo at 20:54 | Comments (0) | TrackBack

FizzBuzzのPerlさいたんきろくたっせい(34ばいと)

FizzBuzzプログラムを書くのが流行っているみたいなので、空気を一切読まずに乱入した。

現在のPerl最短記録はTAKESAKOさんの56byteらしい。
こんなコード

perl -e'die+map{(Fizz)[$_%3].(Buzz)[$_%5]||$_,$/}1..1e2'

まず、元の翻訳文章には「FizzやBuzzや数字のみを出力せよ」とは書いてない事に気づいたので、warnで出してみた。

perl -le'warn((Fizz)[$_%3].(Buzz)[$_%5]||$_)for 1..100'
55byteになった。

次に1から100迄の数値のソースは、別にプログラム側でもっていなくても良い事に気づいたので、これを外だししてみた。
とにかく目的の文字列が出てくればいいのだ。

head -n100 /dev/random|perl -lne'$i++;warn((Fizz)[$i%3].(Buzz)[$i%5]||$i)'
おおすごい!15byte節約に成功して40byteになった!

そういやperl6からsayってのが使えるよね、warnより短くて余計な文字列でないし標準出力でだせるよ!

head -n100 /dev/random|perl -MPerl6::Say -ne '$i++;say((Fizz)[$i%3].(Buzz)[$i%5]||$i)'
39byteになった!

よく考えたら先頭の$i++;いらなくね?

head -n100 /dev/random|perl -MPerl6::Say -ne 'say((Fizz)[++$i%3].(Buzz)[$i%5]||$i)'
36byte!

なんかファイルハンドルの行数取れるやつあったよなぁ、、、$.だっけ?

head -n100 /dev/random|perl -MPerl6::Say -ne 'say((Fizz)[$.%3].(Buzz)[$.%5]||$.)'
sugoi! 34byte!!!!

もう本当にこれが限界じゃないのかしら。

本当はcpan install Acme::FizzBuzzして

perl -MAcme::FizzBuzz -e ''
ってやれば0byteで目的達成するんだけどね。

Posted by Yappo at 04:40 | Comments (4) | TrackBack