The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package Tangram::Relational::Schema;

use strict;
use Tangram::Schema;

sub _deploy_do
{
    my $output = shift;

    return ref($output) && eval { $output->isa('DBI::db') }
		? sub { print $Tangram::TRACE @_, "\n" if $Tangram::TRACE;
			$output->do( join '', @_ ); }
		: sub { print $output @_, ";\n\n" };
}

sub deploy
{
    my ($self, $output) = @_;
    my ($tables, $engine) = @$self;
	my $schema = $engine->{SCHEMA};

    $output ||= \*STDOUT;
    my $driver = $engine->{driver} || Tangram::Relational->new();

    my $do = _deploy_do($output);

    foreach my $table (sort keys %$tables)
    {
	my $def = $tables->{$table};
	my $cols = $def->{COLS};

	my @base_cols;

	my $type = $def->{TYPE} || $schema->{sql}{table_type};

	my $id_col = $schema->{sql}{id_col};
	my $class_col = $schema->{sql}{class_col} || 'type';
	my $timestamp_col = $schema->{sql}{timestamp_col} || '__ts';
	my $timestamp_type = $schema->{sql}{timestamp} || 'TIMESTAMP';
	my $timestamp = $schema->{sql}{timestamp_all_tables};

	push @base_cols,("$id_col ".
			 $driver->type("$schema->{sql}{id} NOT NULL"))
	    if exists $cols->{$id_col};
	push @base_cols, "$class_col "
	    .$driver->type("$schema->{sql}{cid} NOT NULL")
	    if exists $cols->{$class_col};

	push @base_cols, "$timestamp_col "
	    .$driver->type("$timestamp_type NOT NULL")
            if $timestamp;

	delete @$cols{$id_col};
	delete @$cols{$class_col};

	$do->("CREATE TABLE $table\n(\n  ",
	      join( ",\n  ", (@base_cols,
			      map { "$_ ".$driver->type($cols->{$_}) }
			      keys %$cols),
		    ( exists $cols->{$id_col} 
		      ? ("PRIMARY KEY( $id_col )")
		      : () ),
		  ),
	      "\n) ".($type?" TYPE=$type":""));

    }

    my %made_sequence;

    foreach my $class ( values %{$schema->{classes}} ) {
	if ( my $sequence = $class->{oid_sequence} ) {
	    $do->($driver->mk_sequence_sql($sequence))
		unless $made_sequence{$sequence}++;
	}
    }

    my $control = $schema->{control};
    my $table_type = $schema->{sql}{table_type};

    if ( my $sequence = $schema->{sql}{oid_sequence} ) {

	$do->($driver->mk_sequence_sql($sequence))
	    unless $made_sequence{$sequence}++;

    } else {
    $do->( <<SQL . ($table_type?" TYPE=$table_type":"") );
CREATE TABLE $control
(
layout INTEGER NOT NULL,
engine VARCHAR(255),
engine_layout INTEGER,
mark INTEGER NOT NULL
)
SQL

    my $info = $engine->get_deploy_info();
    #my ($l) = split '\.', $Tangram::VERSION;

    # Prevent additional records on redeploy.
    #  -- ks.perl@kurtstephens.com 2004/04/29
    $do->("CREATE UNIQUE INDEX ${control}_Guard ON $control (layout, engine, engine_layout)");

    $do->("INSERT INTO $control (layout, engine, engine_layout, mark)"
	  ." VALUES ($info->{LAYOUT}, '$info->{ENGINE}', "
	  ."$info->{ENGINE_LAYOUT}, 0)");

    }
}

sub retreat
{
    my ($self, $output) = @_;
    my ($tables, $engine) = @$self;
	my $schema = $engine->{SCHEMA};

    $output ||= \*STDOUT;

    my $do = _deploy_do($output);

    my %dropped_sequences;
    my $driver = $engine->{driver} || Tangram::Relational->new();

    my $oid_sequence = $schema->{sql}{oid_sequence};
    for my $table (sort keys %$tables,
		   ($oid_sequence ? () : $schema->{control}))
    {
		$do->( "DROP TABLE $table" );
    }

    for my $class ( values %{ $schema->{classes} } ) {
	if ( my $sequence = $class->{oid_sequence} ) {
	    $do->($driver->drop_sequence_sql($sequence))
		unless $dropped_sequences{$sequence}++;
	}
    }

    if ( $oid_sequence ) {
	$do->($driver->drop_sequence_sql($oid_sequence));
    }
}

# XXX - never reached in the test suite; debugging function?
sub classids
{
    my ($self) = @_;
    my ($tables, $schema) = @$self;
	my $classes = $schema->{classes};
	# use Data::Dumper;
	return { map { $_ => $classes->{$_}{id} } keys %$classes };
}

1;