File Coverage

blib/lib/DBIx/ORM/Declarative/Schema.pm

Criterion	Covered	Total	%
statement	246	404	60.8
branch	34	116	29.3
condition	12	67	17.9
subroutine	21	49	42.8
pod	2	3	66.6
total	315	639	49.3

package DBIx::ORM::Declarative::Schema;

use strict;
use Carp;

use vars qw(@ISA);
@ISA = qw(DBIx::ORM::Declarative);

# Check a create action against constraints, return a data structure suitable
# for use in constructing the required INSERT statement
sub __check_constraints
{
    my ($self, $tab_obj, %params) = @_;
    carp "This method requires an object" and return unless ref $tab_obj;
    my %rv = ();

    # Create a map of constraints by name
    my %cons = map { @{$_}{qw(name constraint)} } $tab_obj->_columns;

    # Primary keys
    my @pk = $tab_obj->_primary_key;

    my @keys = ();
    my @vals = ();
    my @binds = ();
    my $npk = 0;
    if(@pk)
    {
        for my $k (@pk)
        {
            my $v = delete $params{$k};
            if(defined $v)
            {
                if(not $self->apply_method($cons{$k}, 0, $v))
                {
                    carp "column $k constraint failed";
                    return;
                }
                push @binds, $v;
                push @vals, '?';
                push @keys, $k;
            }
            else
            {
                $npk = 1;
                my $fnp = $tab_obj->_for_null_primary;
                if($fnp)
                {
                    push @vals, $fnp;
                    push @keys, $k;
                }
            }
        }
    }

    # Non-primary keys
    for my $k (map { $_->{name} } $tab_obj->_columns)
    {
        next if grep { $_ eq $k } @pk;
        my $v = $params{$k};
        if(not $self->apply_method($cons{$k}, 0, $v))
        {
            carp "column $k constraint failed";
            return;
        }

        # We only need to save the key if it was presented in the parameters
        if(exists $params{$k})
        {
            push @keys, $k;
            if(defined $v)
            {
                push @binds, $v;
                push @vals, '?';
            }
            else
            {
                push @vals, 'NULL';
            }
        }
    }

    # Generate the columns list
    my %n2s = $tab_obj->_column_map;
    my $kstr = '' . join(',', map { $n2s{$_} } @keys);

    # The values string
    my $vstr = '' . join(',', @vals);

    # We return a 1 first, because it's conceivable that everything else
    # is empty
    return (1, $kstr, $vstr, $npk, @binds);
}

# Make a SQL-safe alias from a table's name or alias
sub __make_sql_safe
{
    my ($self, $str) = @_;
    $str =~ s/\W/_/g;
    if($str =~ /^[^a-zA-Z_]/)
    {
        $str = "_$str";
    }
    $str;
}

# Create an alias for a table
sub alias
{
    my ($self, @args) = @_;
    if(@args<2)
    {
        if(@args==1)
        {
            return $self->table(@args);
        }
        my $alias;
        eval { $alias = $self->_alias; };
        return $alias;
    }

    # Create/install a new alias
    my ($alias, $table) = @args;
    my $schema_class = ref $self || $self;
    my $alias_class = $schema_class . "::$alias";
    my $table_class = $schema_class . "::$table";

    # Set it up
    no strict 'refs';
    if(not @{$alias_class . '::ISA'})
    {
        @{$alias_class . '::ISA'} = ($table_class);
        *{$alias_class . '::_class'} = sub { $alias_class; };
        *{$alias_class . '::_table'} = sub { $alias; };
        *{$alias_class . '::_alias'} = sub { $table; };
        my $cons = *{$alias_class} = sub
        {
            my ($self) = @_;
            my $rv = $self->new;
            bless $rv, $alias_class unless $rv->isa($alias_class);
            return $rv;
        } ;

        # Make sure row objects promote to alias objects, NOT table objects
        my $row_class = $alias_class . '::Rows';
        @{$row_class . '::ISA'} = ($self->ROW_CLASS, $alias_class);
        *{$alias_class . '::_row_class'} = sub { $row_class; };

        # Install into the table methods hash
        $self->table_method($alias, $cons);
    }
}

# Get the current table name, or switch to a new table, or create a new
# table class
sub table
{
    my ($self, @args) = @_;
    if(@args<2)
    {
        if(@args==1)
        {
            my $table = shift @args;
            return $self unless $table;
            my $meth = $self->table_method($table);
            return unless $meth;
            return $meth->($self);
        }
        my $table;
        eval { $table = $self->_table; };
        return $table;
    }

    # Get the table's name
    my %args = @args;
    my $table = delete $args{table};
    carp "missing table argument" and return unless $table;
    my $name = delete $args{alias} || $table;

    # Column definitions
    my $primary = delete $args{primary};
    my $unique = delete $args{unique};
    my $columns = delete $args{columns};
    carp "missing column definitions" and return unless
        $primary or $unique or $columns;

    # Other miscellany
    my $onpnull = delete $args{for_null_primary};
    my $selonpnull = delete $args{select_null_primary};
    my $join = delete $args{join_clause};
    my $group_by = delete $args{group_by};

    # class and schema names
    my $super = $self->_schema_class;
    my $table_class = $super . "::$name";
    my $row_class = $table_class . "::Rows";
    my $schema = $self->_schema;

    # Set up the class heirarchy
    no strict 'refs';
    @{$table_class . '::ISA'} = ($super, $self->TABLE_CLASS);
    @{$row_class . '::ISA'} = ($self->ROW_CLASS, $table_class);

    # Information methods
    *{$table_class . '::_class'} = sub { $table_class; };
    *{$table_class . '::_row_class'} = sub { $row_class; };
    *{$table_class . '::_table'} = sub { $name; };
    *{$table_class . '::_sql_name'} = sub { $table; };
    *{$table_class . '::_for_null_primary'} = sub { $onpnull; };
    *{$table_class . '::_select_null_primary'} = sub { $selonpnull; };
    *{$table_class . '::_join_clause'} = sub { $join; };

    # handle GROUP BY
    if($group_by)
    {
        my @p = @$group_by;
        *{$table_class . '::_group_by' } = sub { @p; };
    }
    else
    {
        *{$table_class . '::_group_by' } = sub { };
    }

    # The table object constructor
    my $cons = sub
    {
        my ($self) = @_;
        my $rv = $self->new;
        bless $rv, $table_class unless $rv->isa($table_class);
        return $rv;
    } ;

    *{$table_class} = $cons;

    $self->table_method($name, $cons);

    # Handle column information
    my %seen_keys;
    my @newcolumns;
    my @p;

    # The primary keys
    @p = @$primary if $primary;
    *{$table_class . '::_primary_key'} = sub { @p; };

    # Just in case the primary keys aren't formally defined elsewhere...
    $seen_keys{$_} =
        { sql_name => $_, name => $_, constraint => 'isstring' } foreach @p;
    my %pk = map {($_,1);} @p;
    @newcolumns = @p;

    # Process unique keys
    my @uniqs;
    push @uniqs, [@p] if @p;
        # This is not strictly needed, since the loop will autovivify
        # $unique to contain an empty array ref if it's undefined at this
        # point.  The loop provides the lvalue context to make this work.
    $unique ||= [ ];
    for my $un (@$unique)
    {
        # Check to see if they've duplicated the primary key
        my %kv = map {($_,1)} @$un;
        delete @kv{@p};
        next if not %kv and scalar(@p) == scalar(@$un);

        # Create a copy so they can't change things out from under us
        push @uniqs, [ @$un ];

        # Add the keys to the %seen_keys hash
        for my $k (@$un)
        {
            next if $seen_keys{$k};
            $seen_keys{$k} = { sql_name => $k, name => $k,
                constraint => 'isnullablestring' };
            push @newcolumns, $k;
        }
    }

    # Get the unique keys data
    # For stability, this _should_ be a Readonly variable
    # Unfortunately, Readonly is really slow on older Perls
    *{$table_class . '::_unique_keys' } = sub { @uniqs; };

    # The rest of the column definitions
    my @coldefs;
    my %colmap;
    for my $col (@$columns)
    {
        # Copy the column definition, hack-n-slash at will...
        my %cdef = %$col;

        # Column names
        my $sql_name = delete $cdef{name};
        my $name = delete $cdef{alias} || $sql_name;
        $colmap{$name} = $sql_name;
        delete $seen_keys{$sql_name};

        # Handle constraints and type matching
        my $constraint = delete $cdef{constraint};
        my $match = delete $cdef{matches};
        my $type = delete $cdef{type};
        if (not $constraint)
        {
            # The default constraint is "match EVERYTHING"
            $constraint = 'isnullablestring';

            # If we have a regular expression, use it
            if($match)
            {
                $constraint = sub
                {
                    my ($self, $value) = @_;
                    $value =~ /$match/;
                };
            }

            # Or if we have a type, use that
            elsif($type)
            {
                # We check for every type except nullablestring,
                # because we already set that as the default
                if($type eq 'number') { $constraint = 'isnumber'; }
                elsif($type eq 'string') { $constraint = 'isstring'; }
                elsif($type eq 'nullablenumber')
                {
                    $constraint = 'isnullablenumber';
                }
            }
        }

        # Save the column definition
        push @coldefs,
            {
                sql_name    => $sql_name,
                name        => $name,
                constraint  => $constraint,
                column_name => $sql_name,
            };

        # Create the column method
        *{$row_class . "::$name"} = $self->__create_column_accessor(
            $sql_name, $pk{$sql_name});
    }

    # Add columns for missing primary/unique key components
    for my $col (@newcolumns)
    {
        my $def = delete $seen_keys{$col};
        next unless $def;
        push @coldefs, $def;
        $colmap{$col} = $col;
        *{$row_class . "::$col"} = $self->__create_column_accessor(
            $col, $pk{$col});
    }

    # Save the column and mapping information
    *{$table_class . '::_columns' } = sub { @coldefs; } ;
    *{$table_class . '::_column_map' } = sub { %colmap; } ;
    my @sql_cols = sort values %colmap;
    *{$table_class . '::_column_sql_names' } = sub { @sql_cols; };

    return &{$table_class}($self);
}

# Create a new join, or return the name of this join object
sub join
{
    my ($self, @args) = @_;
    if(@args<2)
    {
        # Turn this into a join object, if requested
        if(@args==1)
        {
            my $join = shift @args;
            return $self unless $join;
            my $meth = $self->join_method($join);
            return unless $meth;
            return $meth->($self);
        }

        my $join;
        eval { $join = $self->_join; };
        return $join;
    }

    # If we get to here, we're adding a new join declaration.
    my %args = @args;
    my $name = delete $args{name};
    carp "duplicate table/join declaration" and return if $self->can($name);

    # Class family names
    my $super = $self->_schema_class;
    my $join_class = $super . "::$name";
    my $row_class = $join_class . '::Rows';
    my $schema = $self->_schema;

    my $ptab = delete $args{primary};
    carp "missing join name" and return unless $name;

    my $tables = delete $args{tables};
    carp "missing table(s) to join" and return unless $ptab and $tables;

    # Look for the table class(es) we need
    my @req_tabs = ($ptab, map { $_->{table} } @$tables);

    carp "missing required tables" and return
        if grep { not $self->can($_); } @req_tabs;

    # Create a primary table object
    my $ptab_obj = $self->table($ptab);
    carp "No such table '$ptab'" and return unless $ptab_obj;

    # Info to create the join
    my $ptab_name = $ptab_obj->_table;
    my $ptab_alias = $self->__make_sql_safe($ptab_name);

    # Primary table's columns
    my @ptab_cols = map { $_->{name} } $ptab_obj->_columns;

    # Will be turned into _sql_name
    my @join_table_info = ($ptab_obj->_sql_name . " $ptab_alias");

    # Will be turned into _columns
    my @column_info =
    map
    {
        (
            {
                sql_name    => "$ptab_alias." . $_->{sql_name},
                name        => $_->{name},
                constraint  => $_->{constraint},
                table       => $ptab_name,
                table_alias => $ptab_alias,
                column_name => $_->{sql_name},
            },
            {
                sql_name    => "$ptab_alias." . $_->{sql_name},
                name        => $ptab_name . '_' . $_->{name},
                constraint  => $_->{constraint},
                table       => $ptab_name,
                table_alias => $ptab_alias,
                column_name => $_->{sql_name},
            },
        )
    }
    $ptab_obj->_columns;

    # Will be turned into _column_map
    my %column_map =
        map { @{$_}{qw(name sql_name)} } @column_info;

    # The "where" clause info
    my @wherefrags;

    # The "group by" clause info
    my @group_by = map { $column_map{$_} } $ptab_obj->_group_by;

    # Primary table's primary keys
    my %pkeys = map {($_ => 1, $ptab_name . "_$_" => 1)}
        $ptab_obj->_primary_key;

    my @tables_seen;

    # Need to clone table info so it doesn't get changed out from under us
    my @tab_info;
    for my $tab (@$tables)
    {
        my $tab_name = $tab->{table};
        my $tab_obj = $self->table($tab_name);

        # No sense doing all the work if the table doesn't exist...
        carp "No such table '$tab_name'" and return unless $tab_obj;
        my $info_ref = { table => $tab_name };

        # Support secondary table joins
        my @use_cols = @ptab_cols;
        my $usetab_name = $ptab_name;
        my $usetab_alias = $ptab_alias;
        my $secondary = $tab->{on_secondary};
        if($secondary)
        {
            carp "Secondary table '$secondary' unknown" and return
                unless grep { $secondary eq $_ } @tables_seen;
            my $secondary_obj = $self->table($secondary);
            carp "No such table '$secondary'" and return unless $secondary_obj;
            $info_ref->{on_secondary} = $secondary;
            @use_cols = map { $_->{name} } $secondary_obj->_columns;
            $usetab_name = $secondary;
            $usetab_alias = $self->__make_sql_safe($usetab_name);
        }

        push @tables_seen, $tab_name;

        my $tab_alias = $self->__make_sql_safe($tab_obj->_table);

        my %join_info = %{$tab->{columns}};
        my @tab_cols = $tab_obj->_columns;
        for my $k (keys %join_info)
        {
            carp "No such key '$k' on primary table '$usetab_name'" and return
                unless grep { $k eq $_ } @use_cols;
            carp "No such key '$k' on secondary table '$tab_name'" and return
                unless grep { $join_info{$k} eq $_->{name} } @tab_cols;

            $info_ref->{columns}{$k} = $join_info{$k};

            # We set the join keys as primary so they don't get changed on us
            $pkeys{$k} = $pkeys{$join_info{$k}} = 1;

            # Save the "where" clause info
            push @wherefrags, "$usetab_alias.$k = $tab_alias.$join_info{$k}";
        }
        # Save the copy
        push @tab_info, $info_ref;

        # Save table join information
        push @join_table_info, $tab_obj->_sql_name . " $tab_alias";

        # Save group by information
        my %tab_group_by = map { ($_,1) } $tab_obj->_group_by;

        # Housekeeping information
        for my $col ($tab_obj->_columns)
        {
            my $column_ref = "$tab_alias." . $col->{sql_name};
            # Save the column information
            push @column_info,
            {
                sql_name    => $column_ref,
                name        => $col->{name},
                constraint  => $col->{constraint},
                table       => $tab_name,
                table_alias => $tab_alias,
                column_name => $_->{sql_name},
            },
            {
                sql_name    => $column_ref,
                name        => $tab_name . '_' .$col->{name},
                constraint  => $col->{constraint},
                table       => $tab_name,
                table_alias => $tab_alias,
                column_name => $_->{sql_name},
            };

            # Save column mapping info
            $column_map{$col->{name}} ||= $column_ref;
            $column_map{$tab_name . '_' . $col->{name}} ||= $column_ref;

            push @group_by, $column_ref if $tab_group_by{$col->{name}};
        }

        # Keep track of housekeeping information
        $pkeys{$tab_name . "_$_"} = $pkeys{$_} = 1
            foreach $tab_obj->_primary_key;
    }

    # We're constructing refs, so turn off strictness
    no strict 'refs';

    # Class heirarchy
    @{$join_class . '::ISA'} = ($super, $self->JOIN_CLASS);
    @{$row_class . '::ISA'} = ($self->JROW_CLASS, $join_class);

    # Information methods
    *{$join_class . '::_class'} = sub { $join_class; };
    *{$join_class . '::_row_class'} = sub { $row_class; };
    *{$join_class . '::_join'} = sub { $name; };
    *{$join_class . '::_primary'} = sub { $ptab; };

    # The stuff to make searching for joins work...
    my $join_tabs = join(', ', @join_table_info);
    *{$join_class . '::_sql_name'} = sub { $join_tabs; };

    my $where_prefix = join(' AND ', @wherefrags);
    *{$join_class . '::_where_prefix'} = sub { $where_prefix; };
    *{$join_class . '::_columns'} = sub { @column_info; };
    *{$join_class . '::_column_map'} = sub { %column_map; };
    *{$join_class . '::_group_by'} = sub { @group_by; };

    # We need to get the list of columns...
    my %h = reverse %column_map;
    my @sql_cols = sort keys %h;
    *{$join_class . '::_column_sql_names' } = sub { @sql_cols; };

    my $cons = sub
    {
        my ($self) = @_;
        my $rv = $self->new;
        bless $rv, $join_class unless $rv->isa($join_class);
        return $rv;
    } ;

    *{$join_class} = $cons;

    $self->join_method($name, $cons);

    *{$join_class . '::_join_info'} = sub { @tab_info; };

    # Create the accessors
    *{$row_class . "::$_" } =
        $self->__create_column_accessor($column_map{$_}, $pkeys{$_})
        foreach keys %column_map;

    # Return success
    return &{$join_class}($self);
}

# Create a method to access column data
sub __create_column_accessor
{
    my ($self, $name, $pk_flag) = @_;
    if($pk_flag)
    {
        # This is a primary key, so it's read-only
        return sub
        {
            my $self = shift;
            carp "$name is not a class method" and return unless ref $self;
            carp "$name is part of the primary key" and return $self if @_;
            return $self->{__data}{$name};
        };
    }

    # If we get to here, it's not a primary key, so we can beat on it
    return sub
    {
        my $self = shift;
        carp "$name is not a class method" and return unless ref $self;
        my $val = $self->{__data}{$name};
        if(@_)
        {
            my $nval = $_[0];
            # Changing undef to undef is not a change...
            return $self if not defined $val and not defined $nval;
            if(not defined $val or $nval ne $val)
            {
                delete $self->{__data}{$name};
                $self->{__data}{$name} = $nval if defined $nval;
                $self->{__dirty} = 1;
            }
            return $self;
        }
        return $val;
    };
}

1;