File Coverage

blib/lib/Class/Dot/Model/Table.pm

Criterion	Covered	Total	%
statement	32	67	47.7
branch	1	8	12.5
condition			n/a
subroutine	10	19	52.6
pod	1	1	100.0
total	44	95	46.3

# $Id: Table.pm 4 2007-09-13 10:16:35Z asksol $
# $Source$
# $Author: asksol $
# $HeadURL: https://class-dot-model.googlecode.com/svn/trunk/lib/Class/Dot/Model/Table.pm $
# $Revision: 4 $
# $Date: 2007-09-13 12:16:35 +0200 (Thu, 13 Sep 2007) $
package Class::Dot::Model::Table;

use strict;
use warnings;
use version; our $VERSION = qv('0.1.3');
use 5.006_001;

use Carp                    qw(croak);
use English                 qw( -no_match_vars );
use Params::Util            qw(_ARRAY);
use Class::Dot::Model::Util qw(
    push_base_class run_as_call_class
    install_coderef FQDN
);

my $BASE_CLASS = 'DBIx::Class';

my @DEFAULT_DBIC_COMPONENTS = qw(
    PK::Auto
    Core
);

my $UPLEVEL = 2;

sub requires {
    my @requires = map { join q{::}, $BASE_CLASS, $_ } @DEFAULT_DBIC_COMPONENTS;
    unshift @requires, $BASE_CLASS;
    return @requires;
}

my %RELATIONSHIPS_FOR;

sub import {
    my $class     = shift;
    my $call_class = caller 0;

    push_base_class($BASE_CLASS => $call_class);

    run_as_call_class(
        $call_class, 'load_components', @DEFAULT_DBIC_COMPONENTS
    );

    return if not scalar @_;

    my @SUBS_TO_EXPORT = qw(
        Table
        Columns
        Primary_Key
        RELATIONSHIPS
    );

    my %SUBROUTINES  = (
        Table           => sub {
            return $call_class->table(@_);
        },
        Columns         => sub {
            my @columns = @_;
            $call_class->add_columns(@columns);
            no strict 'refs'; ## no critic;
            *{ FQDN($call_class, 'COLUMNS') } = sub {
                return wantarray ? @columns : \@columns;
            };
        },
        Primary_Key     => sub {
            return $call_class->set_primary_key(@_);
        },
        Has_Many        => sub {
            $call_class->has_many(@_);
            $RELATIONSHIPS_FOR{$call_class}{$_[0]} = 1;
            return;
        },
        Belongs_To      => sub {
            $call_class->belongs_to(@_);
            $RELATIONSHIPS_FOR{$call_class}{$_[0]} = 1;
        },
        Many_To_Many    => sub {
            $call_class->many_to_many(@_);
            $RELATIONSHIPS_FOR{$call_class}{$_[0]} = 1;
            return;
        },
        Has_One         => sub {
            $call_class->has_one(@_);
            $RELATIONSHIPS_FOR{$call_class}{$_[0]} = 1;
        },
        RELATIONSHIPS   => sub {
            return $RELATIONSHIPS_FOR{$call_class};
        },
    );

    my %EXPORT_TAGS = (
        ':all'          => [ keys %SUBROUTINES                          ],
        ':std'          => [ keys %SUBROUTINES                          ],
        ':has_many'     => [ @SUBS_TO_EXPORT, 'Has_Many', 'Belongs_To', ],
        ':belongs_to'   => [ @SUBS_TO_EXPORT,             'Belongs_To'  ],
        ':child'        => [ @SUBS_TO_EXPORT,                           ],
        ':many_to_many' => [ @SUBS_TO_EXPORT, 'Many_To_Many',           ],
        ':has_one'      => [ @SUBS_TO_EXPORT, 'Has_One',                ],
    );

    for my $arg (@_) {
        if ($arg =~ m/^:/xms) {
            my $export_class_ref = $EXPORT_TAGS{$arg};
            croak "No such export class: $arg"
                if ! _ARRAY($export_class_ref);
            for my $export_sub (@{ $export_class_ref }) {
                install_coderef(
                    $SUBROUTINES{$export_sub} => $call_class, $export_sub
                );
            }
        }
        else {
            my $coderef = $SUBROUTINES{$arg};

            install_coderef(
                $coderef => $call_class, $arg
            );
        }
    }

    return;
}


1;

# TODO
#sub isa_Char {      ## no critic
#    my ($size) = @_;
#
#    return {
#        data_type   => 'char',
#        size        => $size,
#    }
#}
#
#sub isa_Varchar {   ## no critic
#    my ($size) = @_;
#
#    return {
#        data_type   => 'varchar',
#        size        => $size;
#    }
#}
#
#sub isa_ShortInt {  ## no critic
#    return isa_Integer(4);
#}
#
#sub isa_BigInt {    ## no critic
#    return isa_Integer(64);
#}
#
#sub isa_Integer {   ## no critic
#    my ($size) = @_;
#
#    return {
#        data_type   => 'integer',
#        size        => $size,
#    }
#}
#
__END__