package Teng::Schema::Declare;
use strict;
use warnings;
use parent qw(Exporter);
use Teng::Schema;
use Teng::Schema::Table;
our @EXPORT = qw(
schema
name
table
pk
columns
row_class
base_row_class
inflate
deflate
default_row_class_prefix
);
our $CURRENT_SCHEMA_CLASS;
sub schema (&;$) {
my ($code, $schema_class) = @_;
local $CURRENT_SCHEMA_CLASS = $schema_class;
$code->();
_current_schema();
}
sub base_row_class($) {
my $current = _current_schema();
$current->{__base_row_class} = $_[0];
}
sub default_row_class_prefix ($) {
_current_schema()->{__default_row_class_prefix} = $_[0];
}
sub row_namespace ($) {
my $table_name = shift;
my $prefix = defined(_current_schema()->{__default_row_class_prefix}) ? _current_schema()->{__default_row_class_prefix} : do {
(my $caller = caller(1)) =~ s/::Schema$//;
join '::', $caller, 'Row';
};
join '::', $prefix, Teng::Schema::camelize($table_name);
}
sub _current_schema {
my $class = __PACKAGE__;
my $schema_class;
if ( $CURRENT_SCHEMA_CLASS ) {
$schema_class = $CURRENT_SCHEMA_CLASS;
} else {
my $i = 1;
while ( $schema_class = caller($i++) ) {
if ( ! $schema_class->isa( $class ) ) {
last;
}
}
}
if (! $schema_class) {
Carp::confess( "PANIC: cannot find a package name that is not ISA $class" );
}
no warnings 'once';
if (! $schema_class->isa( 'Teng::Schema' ) ) {
no strict 'refs';
push @{ "$schema_class\::ISA" }, 'Teng::Schema';
my $schema = $schema_class->new();
$schema_class->set_default_instance( $schema );
}
$schema_class->instance();
}
sub pk(@);
sub columns(@);
sub name ($);
sub row_class ($);
sub inflate_rule ($@);
sub table(&) {
my $code = shift;
my $current = _current_schema();
my (
$table_name,
@table_pk,
@table_columns,
@inflate,
@deflate,
$row_class,
);
no warnings 'redefine';
my $dest_class = caller();
no strict 'refs';
no warnings 'once';
local *{"$dest_class\::name"} = sub ($) {
$table_name = shift;
$row_class ||= row_namespace($table_name);
};
local *{"$dest_class\::pk"} = sub (@) { @table_pk = @_ };
local *{"$dest_class\::columns"} = sub (@) { @table_columns = @_ };
local *{"$dest_class\::row_class"} = sub (@) { $row_class = shift };
local *{"$dest_class\::inflate"} = sub ($&) {
my ($rule, $code) = @_;
if (ref $rule ne 'Regexp') {
$rule = qr/^\Q$rule\E$/;
}
push @inflate, ($rule, $code);
};
local *{"$dest_class\::deflate"} = sub ($&) {
my ($rule, $code) = @_;
if (ref $rule ne 'Regexp') {
$rule = qr/^\Q$rule\E$/;
}
push @deflate, ($rule, $code);
};
$code->();
my @col_names;
my %sql_types;
while ( @table_columns ) {
my $col_name = shift @table_columns;
if (ref $col_name) {
my $sql_type = $col_name->{type};
$col_name = $col_name->{name};
$sql_types{$col_name} = $sql_type;
}
push @col_names, $col_name;
}
$current->add_table(
Teng::Schema::Table->new(
columns => \@col_names,
name => $table_name,
primary_keys => \@table_pk,
sql_types => \%sql_types,
inflators => \@inflate,
deflators => \@deflate,
row_class => $row_class,
($current->{__base_row_class} ? (base_row_class => $current->{__base_row_class}) : ()),
)
);
}
1;
__END__
=head1 NAME
Teng::Schema::Declare - DSL For Declaring Teng Schema
=head1 NORMAL USE
package MyDB::Schema;
use strict;
use warnings;
use Teng::Schema::Declare;
table {
name "your_table_name";
pk "primary_key";
columns qw( col1 col2 col3 );
inflate 'col1' => sub {
my ($col_value) = @_;
return MyDB::Class->new(name => $col_value);
};
deflate 'col1' => sub {
my ($col_value) = @_;
return ref $col_value ? $col_value->name : $col_value;
};
row_class 'MyDB::Row'; # optional
};
=head1 INLINE DECLARATION
use Teng::Schema::Declare;
my $schema = schema {
table {
name "your_table_name";
columns qw( col1 col2 col3 );
};
} "MyDB::Schema";
=head1 METHODS
=over 4
=item C<schema>
schema data creation wrapper.
=item C<table>
set table name
=item C<pk>
set primary key
=item C<columns>
set columns
=item C<inflate_rule>
set inflate rule
=item C<row_namespace>
create Row class namespace
=item C<base_row_class>
Specify the default base row class with Teng::Schema::Declare.
Default value is L<Teng::Row>.
This option is useful when you adds features for My::DB::Row class.
=item C<default_row_class_prefix>
Specify the default prefix of row class.
C<row_class> of each table definition has priority over C<default_row_class_prefix>.
e.g.:
use Teng::Schema::Declare;
my $schema = schema {
default_row_class_prefix 'My::Entity';
table {
name 'user';
column qw(name);
};
};
$schema->get_row_class('user'); # => My::Entity::User
Default value is determined by the schema class.
e.g.:
package My::DB::Schema;
use Teng::Schema::Declare;
table {
name 'user';
column qw(name);
};
__PACKAGE__->instance->get_row_class('user'); # => My::DB::Row::User
1;
=back
=cut