SQL の CREATE TABLE 文風味のエンティティ・パッケージ定義関数

今日の帰り道の途中で、ふとスカラーカラム名を指定し、他をコードリファレンスで現すようにすると、PerlSQL の CREATE TABLE 文のような感じでエンティティのカラム定義が記述できるのではないかと思いつき、家に戻ってからさっそくおもちゃを書いてみました。

https://gist.github.com/936515 Entity.pm

例えば、Book、Person、Author の3つパッケージを作るには次のように記述します。

use Entity qw(:all);

CREATE_ENTITY('book')->(
    'id' => INTEGER(4), PRIMARY_KEY(),
    'title' => VARCHAR(64),
    'isbn' => VARCHAR(64), UNIQUE(),
);

CREATE_ENTITY('person')->(
    'id' => INTEGER(4), 
    'name' => VARCHAR(64),
    PRIMARY_KEY('id'),
);

CREATE_ENTITY('author')->(
    'book_id' => INTEGER(4),
    'person_id' => INTEGER(4),
    PRIMARY_KEY('book_id', 'person_id'),
);

これらのうち、UNIQUE() は単なる飾りです。PRIMARY_KEY()は、book のようにカラムにつける場合と、author のように独立してカラムを指定する場合の両方に対応しています。上は、次のように書いた場合に似たふるまいをします。ただし、Moose どころか、Mouse も使っておらず、値バリデータ付きの Class::Accessor::Fast みたいなものに過ぎません。

package Book;
use Any::Moose;

has 'id' => {'is' => 'rw', 'isa' => 'Maybe[Int]'};
has 'title' => {'is' => 'rw', 'isa' => 'Maybe[Str]'};
has 'isbn' => {'is' => 'rw', 'isa' => 'Maybe[Str]'};
has 'dirty' => {'is' => 'rw', 'isa' => 'Int'};
sub primary_key { return 'id' }
sub columns { return wantarray ? qw(id title isbn) : 'id, title, isbn' }

package Person;
use Any::Moose;

has 'id' => {'is' => 'rw', 'isa' => 'Maybe[Int]'};
has 'name' => {'is' => 'rw', 'isa' => 'Maybe[Str]'};
has 'dirty' => {'is' => 'rw', 'isa' => 'Int'};
sub primary_key { return 'id' }
sub columns { return wantarray ? qw(id name) : 'id, name' }

package Author;
use Any::Moose;

has 'book_id' => {'is' => 'rw', 'isa' => 'Maybe[Int]'};
has 'person_id' => {'is' => 'rw', 'isa' => 'Maybe[Int]'};
has 'dirty' => {'is' => 'rw', 'isa' => 'Int'};
sub primary_key { return ('book_id', 'person_id') }
sub columns { return wantarray ? qw(book_id person_id) : 'book_id, person_id' }

仕掛けの備忘録です。Entity の大文字の関数は原則としてアクセッサを作成するためのクロージャを返します。例えば、INTEGER 関数を次のように定義しています。

sub INTEGER {
    my($byte_size) = @_;
    $byte_size ||= 4;
    my $min = -(2**($byte_size * 8 - 1));
    my $max = -($min + 1);
    return sub{
        my($name) = @_;
        return entity_accessor($name, 'INTEGER', sub{
            my($v) = @_;
            return $v =~ /\A[+-]?[0-9]+\z/msx && $v >= $min && $v <= $max;
        });
    };
}

クロージャカラム名を与えて呼び出すと、entity_accessor 関数を使って、その整数型へのアクセッサを作ります。これは、Class::Accessor::Fast の作るアクセッサに型チェックを追加したものです。

sub entity_accessor {
    my($name, $type_name, $check_value) = @_;
    return if ! $name;
    return sub {
        my($self, @arg) = @_;
        if (@arg) {
            my($v) = @arg;
            if (! defined $v || $check_value->($v)) {
                $self->{$name} = $v;
                $self->{'_dirty'} = $self->{'_dirty'} | 1;
            }
            else {
                croak "TypeError: ${name} ${type_name}.";
            }
        }
        return $self->{$name};
    };
}

カラム名にアクセッサを割り当てる処理は、CREATE_ENTITY が返すクロージャの役目です。これは単純な状態遷移をおこないながら、カラム名の直後に出現するアクセッサ生成クロージャ($state == 1)を捕まえて、アクセッサをカラム名のシンボルに束縛していきます。

    return sub{
        my(@spec) = @_;
        my %reserved = map { $_ => 1 } qw(
            new entity_name columns primary_key foreign_key dirty
        );
        my @columns;
        my $state = 0;
        my $regex_name = qr/\A[a-z][a-z0-9]*(?:_[a-z0-9]+)*\z/msx;
        for my $x (@spec) {
            if (ref $x eq 'CODE') {
                my $column_name = $columns[-1];
                my $proc = $x->($column_name, $pkg);
                if ($state == 1 && ! $pkg->can($column_name)) {
                    no strict 'refs'; ## no critic qw(NoStrict)
                    *{"${pkg}::${column_name}"} = $proc;
                }
                $state = 2;
            }
            elsif ($x && ! ref $x && $x =~ $regex_name) {
                ! $reserved{$x} or croak "NameError: reserved name '$x'";
                push @columns, $x;
                $state = 1;
            }
            else {
                $state = 2;
            }
        }
        if (! $pkg->can('primary_key')) {
            PRIMARY_KEY()->(undef, $pkg);
        }
        if (! $pkg->can('columns')) {
            _define_columns($pkg, @columns);
        }
    };

PRIMARY_KEY 関数も、primary_key メソッドを生成するクロージャを返します。PRIMARY_KEY 関数にカラム名リストを与えたときは、それを優先してプライマリキーに割り当てます。そうでないときは、クロージャが呼び出されるとき、必ず最後に出現したカラム名が引数に渡されるので、それを使います。これと同様のやりかたで、FOREIGN_KEY も定義できるのでしょうが、実装していません。

sub PRIMARY_KEY {
    my(@primary_key) = @_;
    return sub{
        my($name, $pkg) = @_;
        if ($name && ! @primary_key) {
            push @primary_key, $name;
        }
        no strict 'refs'; ## no critic qw(NoStrict)
        *{"${pkg}::primary_key"} = sub{ @primary_key };
        return;
    };
}