File Coverage

blib/lib/DBIx/Schema/DSL.pm

Criterion	Covered	Total	%
statement	187	197	94.9
branch	49	60	81.6
condition	20	38	52.6
subroutine	39	42	92.8
pod	23	23	100.0
total	318	360	88.3

package DBIx::Schema::DSL;
use 5.008_001;
use strict;
use warnings;

our $VERSION = '0.11';

use Carp qw/croak/;
use Array::Diff;
use DBIx::Schema::DSL::Context;
use SQL::Translator::Schema::Constants;
use SQL::Translator::Schema::Field;

sub context {
    my $pkg = shift;
    die 'something wrong when calling context method.' if $pkg eq __PACKAGE__;
    no strict 'refs';
    ${"$pkg\::CONTEXT"} ||= DBIx::Schema::DSL::Context->new;
}

# don't override CORE::int
use Pod::Functions ();
my @column_methods =
    grep {!$Pod::Functions::Type{$_}} grep { /^[a-zA-Z_][0-9a-zA-Z_]*$/ } keys(%SQL::Translator::Schema::Field::type_mapping), qw/string number enum set/;
my @column_sugars  = qw/unique auto_increment unsigned null/;
my @rev_column_sugars = qw/not_null signed/;
my @export_dsls = qw/
    create_database database    create_table    column      primary_key set_primary_key add_index   add_unique_index
    foreign_key     has_many    has_one         belongs_to  add_table_options   default_unsigned    columns pk  fk
    default_not_null
/;
my @class_methods = qw/context output no_fk_output translate_to translator/;
sub import {
    my $caller = caller;

    no strict 'refs';
    for my $func (@export_dsls, @column_methods, @column_sugars, @class_methods, @rev_column_sugars) {
        *{"$caller\::$func"} = \&$func;
    }
}

sub create_database($) { caller->context->name(shift) }
sub database($)        { caller->context->db(shift)   }

sub add_table_options {
    my $c = caller->context;
    my %opt = @_;

    $c->set_table_extra({
        %{$c->table_extra},
        %opt,
    });

    if ($opt{mysql_charset} && $opt{mysql_charset} eq 'utf8mb4') {
        $c->default_varchar_size(191);
    }
}

sub default_unsigned() {
    caller->context->default_unsigned(1);
}

sub default_not_null() {
    caller->context->default_not_null(1);
}

sub create_table($$) {
    my ($table_name, $code) = @_;

    my $kls = caller;
    my $c = $kls->context;

    $c->_creating_table({
        table_name  => $table_name,
        columns     => [],
        indices     => [],
        constraints => [],
        primary_key => undef,
    });

    $code->();

    my $data = $c->_creating_table;
    my $table = $c->schema->add_table(
        name   => $table_name,
        extra  => {%{$c->table_extra}},
    );
    for my $column (@{ $data->{columns} }) {
        $table->add_field(%{ $column } );
    }

    my @columns = map {$_->{name}} @{$data->{columns}};
    for my $index (@{ $data->{indices} }) {
        if (my @undefined_columns = _detect_undefined_columns(\@columns, $index->{fields})) {
            croak "Index error: Key column [@{[join ', ', @undefined_columns]}] doesn't exist in table]";
        }
        $table->add_index(%{ $index } );
    }
    for my $constraint (@{ $data->{constraints} }) {
        my $cols = $constraint->{fields};
        $cols = [$cols] unless ref $cols;
        if (my @undefined_columns = _detect_undefined_columns(\@columns, $cols)) {
            croak "Constraint error: Key column [@{[join ', ', @undefined_columns]}] doesn't exist in table]";
        }
        $table->add_constraint(%{ $constraint } );
    }

    if (my $pk = $data->{primary_key}) {
        $pk = [$pk] unless ref $pk;
        if (my @undefined_columns = _detect_undefined_columns(\@columns, $pk)) {
            croak "Primary key error: Key column [@{[join ', ', @undefined_columns]}] doesn't exist in table]";
        }
        $table->primary_key($data->{primary_key});
    }

    $c->_clear_creating_table;
}
sub columns(&) {shift}

sub _detect_undefined_columns {
    my ($set, $subset) = @_;

    my $diff = Array::Diff->diff([sort @$set], [sort @$subset]);
    @{$diff->added};
}

sub column($$;%) {
    my ($column_name, $data_type, @opt) = @_;
    croak '`column` function called in non void context' if defined wantarray;

    if (ref $opt[0] eq 'ARRAY') {
        # enum or set
        unshift @opt, 'list';
    }

    if (@opt % 2) {
        croak "odd number elements are assined to options. arguments: [@{[join ', ', @_]}]";
    }
    my %opt = @opt;
    $data_type = 'varchar' if $data_type eq 'string';

    my $c = caller->context;

    my $creating_data = $c->_creating_table
        or croak q{can't call `column` method outside `create_table` method};

    my %args = (
        name      => $column_name,
        data_type => uc $data_type,
    );

    my %map = (
        null           => 'is_nullable',
        limit          => 'size',
        default        => 'default_value',
        unique         => 'is_unique',
        primary_key    => 'is_primary_key',
        auto_increment => 'is_auto_increment',
    );
    for my $key (keys %map) {
        $args{$map{$key}}   = delete $opt{$key} if exists $opt{$key};
    }
    %args = (
        %args,
        %opt
    );

    if (exists $args{unsigned}) {
        $args{extra}{unsigned} = delete $args{unsigned};
    }
    elsif ($c->default_unsigned && $data_type =~ /int(?:eger)?$/) {
        $args{extra}{unsigned} = 1;
    }

    if (exists $args{on_update}) {
        $args{extra}{'on update'} = delete $args{on_update};
    }

    if (exists $args{list}) {
        $args{extra}{list} = delete $args{list};
    }


    if ( !exists $args{is_nullable} && $c->default_not_null ) {
        $args{is_nullable} = 0;
    }

    if ($args{data_type} eq 'VARCHAR' && !$args{size}) {
        $args{size} = $c->default_varchar_size;
    }

    if ($args{precision}) {
        my $precision = delete $args{precision};
        my $scale     = delete $args{scale} || 0;
        $args{size} = [$precision, $scale];
    }

    if ($args{is_primary_key}) {
        $creating_data->{primary_key} = $column_name;
    }
    elsif ($args{is_unique}) {
        push @{$creating_data->{constraints}}, {
            name   => "${column_name}_uniq",
            fields => [$column_name],
            type   => UNIQUE,
        };
    }

    # explicitly add `DEFAULT NULL` if is_nullable and not specified default_value
    if ($args{is_nullable} && !exists $args{default_value} && $args{data_type} !~ /^(?:TINY|MEDIUM|LONG)?(?:TEXT|BLOB)$/ ) {
        $args{default_value} = \'NULL';
    }

    push @{$creating_data->{columns}}, \%args;
}

sub primary_key {
    if (defined wantarray) {
        (primary_key => 1);
    }
    else { # void context
        my $column_name = shift;

        @_ = ($column_name, 'integer', primary_key(), auto_increment(), @_);
        goto \&column;
    }
}
*pk = \&primary_key;

for my $method (@column_methods) {
    no strict 'refs';
    *{__PACKAGE__."::$method"} = sub {
        use strict 'refs';
        my $column_name = shift;

        @_ = ($column_name, $method, @_);
        goto \&column;
    };
}

for my $method (@column_sugars) {
    no strict 'refs';
    *{__PACKAGE__."::$method"} = sub() {
        use strict 'refs';
        ($method => 1);
    };
}
sub not_null() { (null => 0)     }
sub signed()   { (unsigned => 0) }

sub set_primary_key(@) {
    my @keys = @_;

    my $c = caller->context;

    my $creating_data = $c->_creating_table
        or die q{can't call `set_primary_key` method outside `create_table` method};

    $creating_data->{primary_key} = \@keys;
}

sub add_index {
    my $c = caller->context;

    my $creating_data = $c->_creating_table
        or die q{can't call `add_index` method outside `create_table` method};

    my ($idx_name, $fields, $type) = @_;

    push @{$creating_data->{indices}}, {
        name   => $idx_name,
        fields => $fields,
        ($type ? (type => $type) : ()),
    };
}

sub add_unique_index {
    my $c = caller->context;

    my $creating_data = $c->_creating_table
        or die q{can't call `add_unique_index` method outside `create_table` method};

    my ($idx_name, $fields) = @_;

    push @{$creating_data->{indices}}, {
        name   => $idx_name,
        fields => $fields,
        type   => UNIQUE,
    };
}

sub foreign_key {
    my $c = caller->context;

    my $creating_data = $c->_creating_table
        or die q{can't call `foreign` method outside `create_table` method};

    my ($columns, $table, $foreign_columns, %opt) = @_;

    push @{$creating_data->{constraints}}, {
        type => FOREIGN_KEY,
        fields           => $columns,
        reference_table  => $table,
        reference_fields => $foreign_columns,
        %opt,
    };
}
*fk = \&foreign_key;

sub has_many {
    my $c = caller->context;

    my ($table, %opt) = @_;

    my $columns         = delete $opt{column}         || 'id';
    my $foreign_columns = delete $opt{foreign_column} || $c->_creating_table_name .'_id';

    @_ = ($columns, $table, $foreign_columns, %opt);
    goto \&foreign_key;
}

sub has_one {
    my $c = caller->context;

    my ($table, %opt) = @_;

    my $columns         = delete $opt{column}         || 'id';
    my $foreign_columns = delete $opt{foreign_column} || $c->_creating_table_name .'_id';

    @_ = ($columns, $table, $foreign_columns, %opt);
    goto \&foreign_key;
}

sub belongs_to {
    my ($table, %opt) = @_;

    my $columns         = delete $opt{column}         || "${table}_id";
    my $foreign_columns = delete $opt{foreign_column} || 'id';

    @_ = ($columns, $table, $foreign_columns, %opt);
    goto \&foreign_key;
}

sub output {
    shift->context->translate;
}

sub no_fk_output {
    shift->context->no_fk_translate;
}

sub translator {
    shift->context->translator;
}

sub translate_to {
    my ($kls, $db_type) = @_;

    $kls->translator->translate(to => $db_type);
}

1;
__END__