SQL::DB::Schema::Table - Perl representation of an SQL database table

  use SQL::DB::Schema::Table;

  my $table = SQL::DB::Schema::Table->new(
      table   => 'users',
      class   => 'User',
      columns => [
           [name => 'id',  type => 'INT',          primary => 1],
           [name => 'name',type => 'VARCHAR(255)', unique  => 1],
      ],
      index => [
        columns => 'name',
        type    => 'BTREE',
      ],
  );

  print $table->sql;

  #

  [ columns => 'col1,col2', type => $type ]

  use SQL::DB::Schema::Table;

package SQL::DB::Schema::Table;
use strict;
use warnings;
use Carp qw(carp croak confess);
use Scalar::Util qw(weaken);
use SQL::DB::Schema::Column;
use SQL::DB::Row;
use SQL::DB::Schema::ARow;

our $DEBUG;

my @reserved = qw(
    sql
    sql_index
    asc
    desc
    is_null
    not_null
    is_not_null
    exists
); 


sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $self  = {
        columns => [],
        db_type => '',
    };
    bless($self, $class);

    while (my ($key,$val) = splice(@_, 0, 2)) {
        my $action = 'setup_'.$key;
        if (!$self->can($action)) {
            warn "Unknown Table definition: $key";
            next;
        }

        if (ref($val) and ref($val) eq 'ARRAY') {
            $self->$action(@{$val});
        }
        else {
            $self->$action($val);
        }
    }

    # Abstract class setup
    no strict 'refs';
    my $aclass = 'SQL::DB::Schema::ARow::'. $self->{name};
    my $isa = \@{$aclass . '::ISA'};
    if (defined @{$isa}) {
        carp "redefining $aclass";
    }
    push(@{$isa}, 'SQL::DB::Schema::ARow');
    $aclass->mk_accessors($self->column_names_ordered);
    {
        no warnings 'once';
        ${$aclass .'::TABLE'} = $self;
    }

    foreach my $colname ($self->column_names_ordered) {
        *{$aclass .'::set_'. $colname} = sub {
            my $self = shift;
            return $self->$colname->set(@_);
        };
    }

    if (my $class = $self->{class}) {
        my $isa = \@{$class . '::ISA'};
        if (defined @{$isa}) {
            carp "redefining $class";
        }

        my $baseclass = SQL::DB::Row->make_class_from($self->columns);
        push(@{$isa}, $baseclass);
    }

    return $self;
}


sub setup_schema {
    my $self = shift;
    $self->{schema} = shift;
    weaken($self->{schema});
    return;
}


sub setup_table {
    my $self      = shift;
    $self->{name} = shift;
    if ($self->{name} !~ m/[a-z_]/) {
        warn "Table '$self->{name}' is not all lowercase";
    }

}


sub setup_class {
    my $self       = shift;
    $self->{class} = shift;
}


sub setup_bases {
    my $self       = shift;
    foreach my $class (@_) {
        if (!eval "require $class;1;") {
            die "Base Class $class could not be loaded: $@";
        }
    }
    $self->{bases} = [@_];
}


sub setup_column {
    my $self = shift;

    my $col = SQL::DB::Schema::Column->new();
    $col->table($self);

    while (my $key = shift) {
        if ($key eq 'name') {
            my $val = shift;
            if (grep(m/^$val$/, @reserved)) {
                croak "Column can't be called '$val': reserved name";
            }

            if (exists($self->{column_names}->{$val})) {
                croak "Column $val already defined for table $self->{name}";
            }
            $col->name($val);
        }
        else {
            $col->$key(shift);
        }
    }
    $col->name || confess 'Column in table '.$self.' missing name';
    push(@{$self->{columns}}, $col);
    $self->{column_names}->{$col->name} = $col;
    push(@{$self->{column_names_ordered}},$col->name);
}


sub setup_columns {
    my $self = shift;

    foreach my $array (@_) {
        $self->setup_column(@$array);
    }
}


sub setup_primary {
    my $self = shift;
    my $def  = shift;
    map {$_->primary(1)} $self->text2cols($def);
}


sub add_primary {
    my $self = shift;
    push(@{$self->{primary}}, @_);
}


sub setup_unique {
    my $self = shift;
    my $def  = shift;
    push(@{$self->{unique}}, [$self->text2cols($def)]);
}


sub setup_unique_index {
    my $self = shift;
    my $hashref = {unique => 1};

    while (my $def = shift) {
        my $val = shift;
        if ($val) {
            if ($def eq 'columns' and ref($val) and ref($val) eq 'ARRAY') {
                foreach my $col (@{$val}) {
                    (my $c = $col) =~ s/\s.*//;
                if (!exists($self->{column_names}->{$c})) {
                        confess "Index column $c not in table $self->{name}";
                    }
                }
            }
            elsif ($def eq 'columns') {
                my @vals;
                foreach my $col (split(m/,\s*/, $val)) {
                    (my $c = $col) =~ s/\s.*//;
                    if (!exists($self->{column_names}->{$c})) {
                        confess "Index column $c not in table $self->{name}";
                    }
                    push(@vals, $col);
                }
                $val = \@vals;
            }
            $hashref->{$def} = $val;
        }
        else {
            my @vals;
            foreach my $col (split(m/,\s*/, $def)) {
                (my $c = $col) =~ s/\s.*//;
                    if (!exists($self->{column_names}->{$c})) {
                    confess "Index column $c not in table $self->{name}";
                }
                push(@vals, $col);
            }
            $hashref->{columns} = \@vals;
        }
    }
    push(@{$self->{index}}, $hashref);
}


sub setup_index {
    my $self = shift;
    my $hashref = {};

    while (my $def = shift) {
        my $val = shift;
        if ($val) {
            if ($def eq 'columns' and ref($val) and ref($val) eq 'ARRAY') {
                foreach my $col (@{$val}) {
                    (my $c = $col) =~ s/\s.*//;
                if (!exists($self->{column_names}->{$c})) {
                        confess "Index column $c not in table $self->{name}";
                    }
                }
            }
            elsif ($def eq 'columns') {
                my @vals;
                foreach my $col (split(m/,\s*/, $val)) {
                    (my $c = $col) =~ s/\s.*//;
                    if (!exists($self->{column_names}->{$c})) {
                        confess "Index column $c not in table $self->{name}";
                    }
                    push(@vals, $col);
                }
                $val = \@vals;
            }
            $hashref->{$def} = $val;
        }
        else {
            my @vals;
            foreach my $col (split(m/,\s*/, $def)) {
                (my $c = $col) =~ s/\s.*//;
                    if (!exists($self->{column_names}->{$c})) {
                    confess "Index column $c not in table $self->{name}";
                }
                push(@vals, $col);
            }
            $hashref->{columns} = \@vals;
        }
    }
    push(@{$self->{index}}, $hashref);
}


sub setup_foreign {
    my $self = shift;
    warn 'multi foreign not implemented yet';
}


sub setup_trigger {
    my $self = shift;
    my $trigger = shift || confess 'trigger not defined';
    ref($trigger) eq 'HASH' || confess 'trigger must be HASH ref';
    push(@{$self->{triggers}}, $trigger);
}


sub setup_type_mysql {
    my $self = shift;
    $self->{engine_mysql} = shift;
}


sub setup_engine_mysql {
    my $self = shift;
    $self->{engine_mysql} = shift;
}


sub setup_default_charset_mysql {
    my $self = shift;
    $self->{default_charset_mysql} = shift;
}


sub setup_default_charset_pg {
    my $self = shift;
    $self->{default_charset_pg} = shift;
}


sub setup_tablespace_pg {
    my $self = shift;
    $self->{tablespace_pg} = shift;
}


sub text2cols {
    my $self = shift;
    my $text = shift;
    my @cols = ();

    if (ref($text) and ref($text) eq 'ARRAY') {
        return map {$self->text2cols($_)} @{$text};
    }

    if (ref($text)) {
        confess "text2cols called with non-scalar and non-arrayref: $text";
    }

    if ($text =~ /\s*(.*)\s*\((.*)\)/) {
        my $table;
        unless (eval {$table = $self->{schema}->table($1);1;}) {
            confess "Table $self->{name}: Foreign table $1 not yet defined.\n".
                  "Known tables: " 
                    . join(',', map {$_->name} $self->{schema}->tables);
        }
        foreach my $column_name (split(/,\s*/, $2)) {
            unless($table->column($column_name)) {
                confess "Table $self->{name}: Foreign table '$1' has no "
                     ."column '$column_name'";
            }
            push(@cols, $table->column($column_name));
        }
    }
    else {
        foreach my $column_name (split(/,\s*/, $text)) {
            unless(exists($self->{column_names}->{$column_name})) {
                confess "Table $self->{name}: No such column '$column_name'";
            }
            push(@cols, $self->{column_names}->{$column_name});
        }
    }
    if (!@cols) {
        confess 'No columns found in text: '. $text;
    }
    return @cols;
}


sub name {
    my $self = shift;
    return $self->{name};
}


sub class {
    my $self = shift;
    return $self->{class};
}


sub columns {
    my $self = shift;
    return @{$self->{columns}};
}


sub column_names {
    my $self = shift;
    return sort keys %{$self->{column_names}};
}


sub column_names_ordered {
    my $self = shift;
    return @{$self->{column_names_ordered}};
}


sub column {
    my $self = shift;
    my $name = shift;
    if (!exists($self->{column_names}->{$name})) {
        return;
    }
    return $self->{column_names}->{$name};
}


sub primary_columns {
    my $self = shift;
    return @{$self->{primary}} if($self->{primary});
    return;
}


sub primary_column_names {
    my $self = shift;
    return map {$_->name} @{$self->{primary}} if($self->{primary});
    return;
}


sub ref_by {
    my $self = shift;
    if (@_) {
        my $table = shift;
        $self->{ref_by}->{$table->name} = $table;
        weaken($self->{ref_by}->{$table->name});
    }
    return values %{$self->{ref_by}};
}


sub arow {
    my $self   = shift;
    my $class  = 'SQL::DB::Schema::ARow::' . $self->name;
    return $class->new;
}


sub schema {
    my $self = shift;
    return $self->{schema};
}


sub set_db_type {
    my $self = shift;
    $self->{db_type} = shift || confess 'usage: set_db_type($type)';
}


sub db_type {
    my $self = shift;
    return $self->{db_type} || '';
}


sub sql_primary {
    my $self = shift;
    if (!$self->{primary}) {
        return '';
    }
    return 'PRIMARY KEY('
           . join(', ', map {$_->name} @{$self->{primary}}) .')';
}


sub sql_unique {
    my $self = shift;

    if (!$self->{unique}) {
        return ();
    }

    my @sql = ();

    # a list of arrays
    foreach my $u (@{$self->{unique}}) {
        push(@sql, 'UNIQUE ('
                . join(', ', map {$_->name} @{$u})
                . ')'
        );
    }

    return @sql;
}


sub sql_foreign {
    my $self = shift;
    if (!$self->{foreign}) {
        return '';
    }
    my $sql = '';
    foreach my $f (@{$self->{foreign}}) {
        my @cols = @{$f->{columns}};
        my @refs = @{$f->{references}};
        $sql .= 'FOREIGN KEY ('
                . join(', ', @cols)
                . ') REFERENCES ' . $refs[0]->table->name .' ('
                . join(', ', @refs)
                . ')'
        ;
    }
    return $sql;
}


sub sql_engine_mysql {
    my $self = shift;
    unless ($self->{db_type} eq 'mysql' and $self->{engine_mysql}) {
        return '';
    }
    return ' ENGINE='.$self->{engine_mysql};
}


sub sql_default_charset_mysql {
    my $self = shift;
    unless ($self->{db_type} eq 'mysql' and $self->{default_charset_mysql}) {
        return '';
    }
    return ' DEFAULT CHARACTER SET '.$self->{default_charset_mysql};
}


sub sql_default_charset_pg {
    my $self = shift;
    unless ($self->{db_type} eq 'pg' and $self->{default_charset_pg}) {
        return '';
    }
    return ' DEFAULT_CHARSET='.$self->{default_charset_pg};
}


sub sql_create_table {
    my $self = shift;
    my @vals = map {$_->sql} $self->columns;
    push(@vals, $self->sql_primary) if ($self->{primary});
    push(@vals, $self->sql_unique) if ($self->{unique});
    push(@vals, $self->sql_foreign) if ($self->{foreign});

    return 'CREATE TABLE '
           . $self->{name}
           . " (\n    " . join(",\n    ", @vals) . "\n)"
           . $self->sql_engine_mysql
           . $self->sql_default_charset_mysql
           . $self->sql_default_charset_pg
    ;
}

sub sql_create_indexes {
    my $self = shift;
    my @sql = ();

    foreach my $index (@{$self->{index}}) {
        my @cols = @{$index->{columns}};
        my @colsflat;
        foreach (@cols) {
            (my $x = $_) =~ s/\s/_/g;
            push(@colsflat, $x);
        }
        push(@sql, 'CREATE'
                . ($index->{unique} ? ' UNIQUE' : '')
                . ' INDEX '
                . join('_',$self->{name}, @colsflat)
                . ' ON ' . $self->{name}
                . ($index->{using} ? ' USING '.$index->{using} : '')
                . ' (' . join(',', @cols) . ')'
        );
    }
    return @sql;
}

sub sql_triggers {
    my $self = shift;
    return () unless($self->{triggers});

    my $type = $self->{db_type} || 'SQLite';
    my @triggers;

    foreach my $trigger (@{$self->{triggers}}) {
        next unless(exists $trigger->{$type});
        push(@triggers, $trigger->{$type});
    }

    return @triggers;
}


sub sql_create {
    my $self = shift;
    return ($self->sql_create_table, $self->sql_create_indexes,
            $self->sql_triggers);
}


DESTROY {
    my $self = shift;
    warn 'DESTROY Table '.$self->name if($DEBUG and $DEBUG>2);
}


1;
__END__

# vim: set tabstop=4 expandtab:

# vim: set tabstop=4 expandtab: