DBIx::Simple で UTF8Columns したい

しつこく DBIx::Simple を使っていきますが,使っていて困ることの一つは DB から取得したデータが octet stream のままであること。もちろんモデルクラス(DB へのアクセサ)で面倒をみてやればいいのですが,DBIC とかモダンなものだと DBIx::Class::UTF8Columns みたいに内部 Unicode にしてくれるヘルパがあったりします。

以前も思いましたがこの辺は DBD か DBI が面倒見るべきじゃないかな?でもそうしちゃうと既存のコードの互換性が保てないからアレなのかな?

ともかくルーズに utf8 したい。

ってことでコードをでっちあげてみました。DBIx::Simple のコードを読むと,

  • DB に投げる際は必ず DBIx::Simple::query() を通るっぽい
  • DBIx::Simple::query() が結果含むデータを DBIx::Simple::Result に bless
  • DB から受け取ったものは DBIx::Simple::Result を経由してアクセス

だったので,Result クラスを継承して変換処理を加えつつ,query() 上書きして新しい Result クラスを返すようにしてます。同じような記述の繰り返しで格好悪いですが。

デフォルトで DB 側のコードは UTF-8 を仮定してますが,$db->encoding('euc-jp') とかすると変更できるようにしてます。また,DBIx::Simple::OO は DBIx::Simple::Result にメソッドを足してるだけなので,そのまま使えます。

use DBIx::Simple::UTF8Columns;
use DBIx::Simple::OO;
use utf8;

my $db = DBIx::Simple::UTF8Columns->connect(...);
$db->encoding('euc-jp');

my $book = $db->select(
    'books', '*',
    {
        title => { 'LIKE' => 'はじめての%' },
    },
)->object;

if ($book->author =~ m//) { ... }

こんな感じで書ける,はず。こんなサンプルでは内部 Unicode にする旨みもなにもあったもんじゃないですけど。

ちなみにテーブル名やフィールド名は latin chars を仮定してます(変換してない)…とほほ

use strict;
use warnings;
use Carp ();
use utf8;
use Encode ();

$Carp::Internal{$_} = 1
    for qw( DBIx::Simple::UTF8Columns
            DBIx::Simple::UTF8Columns::Result );

package DBIx::Simple::UTF8Columns;

use base qw( DBIx::Simple );

our $DEFAULT_ENCODING = 'utf8';

sub encoding {
    my $self = shift;
    
    if (! ref $self) {      # class method
        if (@_) {
            $DEFAULT_ENCODING = shift;
        }
        return $DEFAULT_ENCODING;
    }
    else {                  # instance method
        if (@_) {
            $self->{_encoding} = shift;
            $self->{_encoder}  = undef;
        }
        elsif (! defined $self->{_encoding}) {
            $self->{_encoding} = $DEFAULT_ENCODING;
            $self->{_encoder}  = undef;
        }
        return $self->{_encoding};
    }
}

sub _encoder {
    my $self = shift;
    
    if (! defined $self->{_encoder}) {
        $self->{_encoder} = Encode::find_encoding($self->encoding);
    }
    
    return $self->{_encoder};
}

sub query {
    my ($self, $query, @binds) = @_;
    
    foreach my $data ($query, @binds) {
        if (! ref $data && utf8::is_utf8($data)) {
            $data = $self->_encoder->encode($data);
        }
    }
    
    my $result = $self->SUPER::query($query, @binds);
    
    if (defined $result) {
        bless $result, 'DBIx::Simple::UTF8Columns::Result';
        
        $result->{_encoder} = $self->_encoder;
    }
    
    return $result;
}

package DBIx::Simple::UTF8Columns::Result;

use base qw( DBIx::Simple::Result );

sub _encoder {
    return $_[0]->{_encoder};
}

sub _decode {
    my ($self, $data) = @_;
    
    if (! utf8::is_utf8($data)) {
        $data = $self->_encoder->decode($data);
    }
    return $data;
}

sub _encode {
    my ($self, $data) = @_;
    
    if (utf8::is_utf8($data)) {
        $data = $self->_encoder->encode($data);
    }
    return $data;
}

# UNSUPPORTED: func, attr
# UNTOUCH:     columns
# UNSUPPORTED: bind, fetch, into

sub list {
    my $self = shift;
    
    my @results = $self->SUPER::list(@_);
    
    if (wantarray) {
        foreach my $result (@results) {
            $result = $self->_decode($result);
        }
        return @results;
    }
    else {
        return $self->_decode($results[-1]);
    }
}

sub array {
    my $self = shift;
    
    my $result = $self->SUPER::array(@_);
    
    if (defined $result) {
        my @results = @{ $self->SUPER::array(@_) };
        foreach my $data (@results) {
            $data = $self->_decode($data);
        }
        $result = \@results;
    }
    
    return $result;
}

sub hash {
    my $self = shift;
    
    my $ref_results = $self->SUPER::hash(@_);
    
    if (defined $ref_results) {
        foreach my $result (values %$ref_results) {
            $result = $self->_decode($result);
        }
    }
    
    return $ref_results;
}

# UNTOUCH:     flat

sub arrays {
    my $self = shift;
    
    my @results = $self->SUPER::arrays(@_);
    foreach my $result (@results) {
        foreach my $column (@$result) {
            $column = $self->_decode($column);
        }
    }
    return wantarray ? @results : \@results;
}

# UNTOUCH:     hashes, map_hashes, map_arrays, map, rows
# UNSUPPORTED: xto, html, table

1;

追記 2007/01/10

sub arrays() の実装がおかしかったのでなおした

追記 2007/06/11

CPAN にあげました。ので上記のコードは古いです。つーか CPAN Author デビュー。超はづい。