Tangram/Relational/Engine.pm

# (c) Sound Object Logic 2000-2001

use strict;

package Tangram::Relational::TableSet;

use constant TABLES => 0;
use constant SORTED_TABLES => 1;
use constant KEY => 2;

sub new
  {
        my $class = shift;
        my %seen;
        my @tables = grep { !$seen{$_}++ } @_;
        my @sorted_tables = sort @tables;

        return bless [ \@tables, \@sorted_tables, "@sorted_tables" ], $class;
  }

sub key
  {
        return shift->[KEY];
  }

sub tables
  {
        @{ shift->[TABLES] }
  }

sub is_improper_superset
  {
        my ($self, $other) = @_;
        my %other_tables = map { $_ => 1 } $other->tables();
        
        for my $table ($self->tables()) {
          delete $other_tables{$table};
          return 1 if keys(%other_tables) == 0;
        }

        return 0;
  }

package Tangram::Relational::Engine;

sub new
  {
        my ($class, $schema, %opts) = @_;

        my $heterogeneity = { };
        my $engine = bless { SCHEMA => $schema, HETEROGENEITY => $heterogeneity }, $class;

        if ($opts{layout1}) {
          $engine->{layout1} = 1;
          $engine->{TYPE_COL} = $schema->{sql}{class_col} || 'classId';
        } else {
          $engine->{TYPE_COL} = $schema->{sql}{class_col} || 'type';
        }

        for my $class ($schema->all_classes) {
          $engine->{ROOT_TABLES}{$class->{table}} = 1
                if $class->is_root();
        }

        for my $class ($schema->all_classes) {

          $engine->{ROOT_TABLES}{$class->{table}} = 1
                if $class->is_root();

          next if $class->{abstract};

          my $table_set = $engine->get_table_set($class);
          my $key = $table_set->key();

          for my $other ($schema->all_classes) {
                ++$heterogeneity->{$key} if my $ss = $engine->get_table_set($other)->is_improper_superset($table_set);
                my $other_key = $engine->get_table_set($other)->key;
          }
        }

        # use Data::Dumper; print Dumper $heterogeneity;

        return $engine;
  }

sub get_table_set
  {
        my ($self, $class) = @_;

        return $self->{CLASSES}{$class->{name}}{table_set} ||= do {

          my @table;

          if ($self->{ROOT_TABLES}{$class->{table}}) {
                push @table, $class->{table};
          } else {
                my $context = { layout1 => $self->{layout1} };
                
                for my $field ($class->direct_fields()) {
                  if ($field->get_export_cols($context)) {
                        push @table, $class->{table};
                        last;
                  }
                }
          }

          Tangram::Relational::TableSet
                ->new((map { $self->get_table_set($_)->tables } $class->direct_bases()), @table );
        };
  }

sub get_parts
  {
        my ($self, $class) = @_;

        @{ $self->{CLASSES}{$class->{name}}{PARTS} ||= do {
          my %seen;
          [ grep { !$seen{ $_->{name} }++ }
                (map { $self->get_parts($_) } $class->direct_bases()),
                $class
          ]
        } }
  }

sub get_save_cache
  {
        my ($self, $class) = @_;

        return $self->{CLASSES}{$class}{SAVE} ||= do {
          
          my $schema = $self->{SCHEMA};
          my $id_col = $schema->{sql}{id_col};
          my $type_col = $self->{TYPE_COL};

          my (%tables, @tables);
          my (@export_sources, @export_closures);
          
          my $context = { layout1 => $self->{layout1} };

          my $field_index = 2;

          for my $part ($self->get_parts($class)) {
                my $table_name = $part->{table};

                $context->{class} = $part;

                my $table = $tables{$table_name} ||= do { push @tables, my $table = [ $table_name, [], [] ]; $table };
                
                for my $field ($part->direct_fields()) {
                  
                  my $exporter = $field->get_exporter($context)
                        or next;
                  
                  if (ref $exporter) {
                        push @export_closures, $exporter;
                        push @export_sources, 'shift(@closures)->($obj, $context)';
                  } else {
                        push @export_sources, $exporter;
                  }

                  my @export_cols = $field->get_export_cols($context);
                  push @{ $table->[1] }, @export_cols;
                  push @{ $table->[2] }, $field_index..($field_index + $#export_cols);
                  $field_index += @export_cols;
                }
          }

          my $export_source = join ",\n", @export_sources;
          my $copy_closures = @export_closures ? ' my @closures = @export_closures;' : '';

          # $Tangram::TRACE = \*STDOUT;

          $export_source = "sub { my (\$obj, \$context) = \@_;$copy_closures\n$export_source }";

          print $Tangram::TRACE "Compiling exporter for $class->{name}...\n$export_source\n"
                if $Tangram::TRACE;

          # use Data::Dumper; print Dumper \@cols;
          my $exporter = eval $export_source or die;

          my (@inserts, @updates, @insert_fields, @update_fields);

          for my $table (@tables) {
                my ($table_name, $cols, $fields) = @$table;
                my @meta = ( $id_col );
                my @meta_fields = ( 0 );

                if ($self->{ROOT_TABLES}{$table_name}) {
                  push @meta, $type_col;
                  push @meta_fields, 1;
                }

                next unless @meta > 1 || @$cols;
                
                push @inserts, sprintf('INSERT INTO %s (%s) VALUES (%s)',
                                                                $table_name,
                                                                join(', ', @meta, @$cols),
                                                                join(', ', ('?') x (@meta + @$cols)));
                push @insert_fields, [ @meta_fields, @$fields ];

                if (@$cols) {
                  push @updates, sprintf('UPDATE %s SET %s WHERE %s = ?',
                                                                 $table_name,
                                                                 join(', ', map { "$_ = ?" } @$cols),
                                                                 $id_col);
                  push @update_fields, [ @$fields, 0 ];
                }
          }

          {
                EXPORTER => $exporter,
                INSERT_FIELDS => \@insert_fields, INSERTS => \@inserts,
                UPDATE_FIELDS => \@update_fields, UPDATES => \@updates,
          }
        };
  }

sub get_instance_select
  {
        my ($self, $class) = @_;
        
        return $self->{CLASSES}{$class}{INSTANCE_SELECT} ||= do {
          my $schema = $self->{SCHEMA};
          my $id_col = $schema->{sql}{id_col};
          my $context = { engine => $self, schema => $schema, layout1 => $self->{layout1} };
          my @cols;
          
          for my $part ($self->get_parts($class)) {
                my $table = $part->{table};
                $context->{class} = $part;
                push @cols, map { "$table.$_" } map { $_->get_import_cols($context) } $part->direct_fields()
          }

          my ($first_table, @other_tables) = $self->get_table_set($class)->tables();

          sprintf("SELECT %s FROM %s WHERE %s",
                          join(', ', @cols),
                          join(', ', $first_table, @other_tables),
                          join(' AND ', "$first_table.$id_col = ?", map { "$first_table.$id_col = $_.$id_col" } @other_tables));
        };
  }

sub get_polymorphic_select
  {
        my ($self, $class, $storage) = @_;
        
        my $selects = $self->{CLASSES}{$class}{POLYMORPHIC_SELECT} ||= do {
          my $schema = $self->{SCHEMA};
          my $id_col = $schema->{sql}{id_col};
          my $type_col = $self->{TYPE_COL};
          my $context = { engine => $self, schema => $schema, layout1 => $self->{layout1} };
          
          my $table_set = $self->get_table_set($class);
          my %base_tables = do { my $ph = 0; map { $_ => $ph++ } $table_set->tables() };
          
          my %partition;
          
          $class->for_conforming(sub {
                                                           my $class = shift;
                                                           push @{ $partition{ $self->get_table_set($class)->key } }, $class
                                                                 unless $class->{abstract};
                                                         } );
          
          my @selects;
          
          for my $table_set_key (keys %partition) {

                my $mates = $partition{$table_set_key};
                
                my %slice;
                my %col_index;
                my $col_mark = 0;
                my (@cols, @expand);
                
                my @tables = $self->get_table_set($mates->[0])->tables();
                
                my $root_table = $tables[0];
                push @cols, qualify($id_col, $root_table, \%base_tables, \@expand);
                push @cols, qualify($type_col, $root_table, \%base_tables, \@expand);
                
                my %used;
                $used{$root_table} += 2;

                for my $class (@$mates) {
                  my @slice;
                  
                  for my $part ($self->get_parts($class)) {
                        my $table = $part->{table};
                        $context->{class} = $part;
                        
                        for my $field ($part->direct_fields()) {
                          my @import_cols = $field->get_import_cols($context);
                          $used{$table} += @import_cols;

                          for my $col (@import_cols) {
                                my $qualified_col = "$table.$col";
                                unless (exists $col_index{$qualified_col}) {
                                  push @cols, qualify($col, $table, \%base_tables, \@expand);
                                  $col_index{$qualified_col} = $col_mark++;
                                }

                                push @slice, $col_index{$qualified_col};
                          }
                        }
                  }
                  
                  $slice{ $storage->{class2id}{$class->{name}} || $class->{id} } = \@slice; # should be $class->{id} (compat)
                }
                
                my @from;
                
                for my $table (@tables) {
                  next unless $used{$table};
                  if (exists $base_tables{$table}) {
                        push @expand, $base_tables{$table};
                        push @from, "$table t%d";
                  } else {
                        push @from, $table;
                  }
                }
                
                my @where = map {
                  qualify($id_col, $root_table, \%base_tables, \@expand) . ' = ' . qualify($id_col, $_, \%base_tables, \@expand)
                } grep { $used{$_} } @tables[1..$#tables];

                unless (@$mates == $self->{HETEROGENEITY}{$table_set_key}) {
                  push @where, sprintf "%s IN (%s)", qualify($type_col, $root_table, \%base_tables, \@expand),
                  join ', ', map {
                        $storage->{class2id}{$_->{name}} or $_->{id} # try $storage first for compatibility with layout1
                  } @$mates
                }
                
                push @selects, Tangram::Relational::PolySelectTemplate->new(\@expand, \@cols, \@from, \@where, \%slice);
          }

          \@selects;
        };

        return @$selects;
  }

sub qualify
  {
        my ($col, $table, $ph, $expand) = @_;
        
        if (exists $ph->{$table}) {
          push @$expand, $ph->{$table};
          return "t%d.$col";
        } else {
          return "$table.$col";
        }
  }

sub get_import_cache
  {
    my ($self, $class) = @_;

        return $self->{CLASSES}{$class}{IMPORTER} ||=
          do {
                my $schema = $self->{SCHEMA};
                
                my $context = { schema => $schema, layout1 => $self->{layout1} };
                
                my (@import_sources, @import_closures);
                
                for my $part ($self->get_parts($class)) {
                  my $table_name = $part->{table};
                  
                  $context->{class} = $part;

                  for my $field ($part->direct_fields) {
                        
                        my $importer = $field->get_importer($context)
                          or next;
                        
                        if (ref $importer) {
                          push @import_closures, $importer;
                          push @import_sources, 'shift(@closures)->($obj, $row, $context)';
                        } else {
                          push @import_sources, $importer;
                        }
                  }
                }
                
                my $import_source = join ";\n", @import_sources;
                my $copy_closures = @import_closures ? ' my @closures = @import_closures;' : '';
                
                # $Tangram::TRACE = \*STDOUT;
                
                $import_source = "sub { my (\$obj, \$row, \$context) = \@_;$copy_closures\n$import_source }";
                
                print $Tangram::TRACE "Compiling importer for $class->{name}...\n$import_source\n"
                  if $Tangram::TRACE;
                
                # use Data::Dumper; print Dumper \@cols;
                eval $import_source or die;
          };
  }

sub get_deletes
  {
        my ($self, $class) = @_;
        
        return $self->{CLASSES}{$class}{DELETES} ||= do {
          my $id_col = $self->{SCHEMA}{sql}{id_col};
          [ map { "DELETE FROM $_ WHERE $id_col = ?" } $self->get_table_set($class)->tables() ]
        };
  }

sub deploy
{
        my ($self, $out) = @_;
    $self->relational_schema()->deploy($out);
}

sub retreat
{
        my ($self, $out) = @_;
    $self->relational_schema()->retreat($out);
}

sub get_deploy_info
  {
        my ($self) = @_;
        return { LAYOUT => 2, ENGINE => ref($self), ENGINE_LAYOUT => 1 };
  }

sub relational_schema
  {
    my ($self) = @_;
        
        my $schema = $self->{SCHEMA};
    my $classes = $schema->{classes};
    my $tables = {};
        
    foreach my $class (keys %{$schema->{classes}}) {

          my $classdef = $classes->{$class};
          my $tabledef = $tables->{ $classdef->{table} } ||= {};
          my $cols = $tabledef->{COLS} ||= {};
          
          $cols->{ $schema->{sql}{id_col} } = $schema->{sql}{id};

          $cols->{ $schema->{sql}{class_col} || 'type' } = $schema->{sql}{cid} if $self->{ROOT_TABLES}{$classdef->{table}};

          $tables->{$class}->{SQL} = $classdef->{sql} if $classdef->{sql};
          
          foreach my $typetag (keys %{$classdef->{members}})
                {
                  my $members = $classdef->{members}{$typetag};
                  my $type = $schema->{types}{$typetag};
                  
                  $type->coldefs($tabledef->{COLS}, $members, $schema, $class, $tables);
                }
    }
        
    delete @$tables{ grep { 1 == keys %{ $tables->{$_}{COLS} } } keys %$tables };
        
    return bless [ $tables, $self ], 'Tangram::RelationalSchema';
}

sub Tangram::Scalar::_coldefs
{
    my ($self, $cols, $members, $sql, $schema) = @_;

    for my $def (values %$members)
    {
                $cols->{ $def->{col} } = $def->{sql} || "$sql $schema->{sql}{default_null}";
    }
}
sub Tangram::Integer::coldefs
{
    my ($self, $cols, $members, $schema) = @_;
    $self->_coldefs($cols, $members, 'INT', $schema);
}

sub Tangram::Real::coldefs
{
    my ($self, $cols, $members, $schema) = @_;
    $self->_coldefs($cols, $members, 'REAL', $schema);
}

# sub Tangram::Ref::coldefs
# {
#     my ($self, $cols, $members, $schema) = @_;

#     for my $def (values %$members)
#     {
#               $cols->{ $def->{col} } = !exists($def->{null}) || $def->{null}
#                       ? "$schema->{sql}{id} $schema->{sql}{default_null}"
#                       : $schema->{sql}{id};
#     }
# }

sub Tangram::String::coldefs
{
    my ($self, $cols, $members, $schema) = @_;
    $self->_coldefs($cols, $members, 'VARCHAR(255)', $schema);
}

sub Tangram::Set::coldefs
{
    my ($self, $cols, $members, $schema, $class, $tables) = @_;

    foreach my $member (values %$members)
    {
                $tables->{ $member->{table} }{COLS} =
                {
                 $member->{coll} => $schema->{sql}{id},
                 $member->{item} => $schema->{sql}{id},
                };
    }
}

sub Tangram::IntrSet::coldefs
{
    my ($self, $cols, $members, $schema, $class, $tables) = @_;

    foreach my $member (values %$members)
    {
                my $table = $tables->{ $schema->{classes}{$member->{class}}{table} } ||= {};
                $table->{COLS}{$member->{coll}} = "$schema->{sql}{id} $schema->{sql}{default_null}";
    }
}

sub Tangram::Array::coldefs
{
    my ($self, $cols, $members, $schema, $class, $tables) = @_;

    foreach my $member (values %$members)
    {
                $tables->{ $member->{table} }{COLS} =
                {
                 $member->{coll} => $schema->{sql}{id},
                 $member->{item} => $schema->{sql}{id},
                 $member->{slot} => "INT $schema->{sql}{default_null}"
                };
    }
}

sub Tangram::Hash::coldefs
{
    my ($self, $cols, $members, $schema, $class, $tables) = @_;

    foreach my $member (values %$members)
    {
                $tables->{ $member->{table} }{COLS} =
                {
                 $member->{coll} => $schema->{sql}{id},
                 $member->{item} => $schema->{sql}{id},
                 $member->{slot} => "VARCHAR(255) $schema->{sql}{default_null}"
                };
    }
}

sub Tangram::IntrArray::coldefs
{
    my ($self, $cols, $members, $schema, $class, $tables) = @_;

    foreach my $member (values %$members)
    {
                my $table = $tables->{ $schema->{classes}{$member->{class}}{table} } ||= {};
                $table->{COLS}{$member->{coll}} = "$schema->{sql}{id} $schema->{sql}{default_null}";
                $table->{COLS}{$member->{slot}} = "INT $schema->{sql}{default_null}";
    }
}

sub Tangram::HashRef::coldefs
{
    #later
}

sub Tangram::BackRef::coldefs
{
    return ();
}

package Tangram::RelationalSchema;

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 $do = _deploy_do($output);

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

                my @base_cols;
                my $id_col = $schema->{sql}{id_col};
                my $class_col = $schema->{sql}{class_col} || 'type';
                my $table_type = $sql->{table_type} || $schema->{sql}{table_type};

                push @base_cols, "$id_col $schema->{sql}{id} NOT NULL,\n  PRIMARY KEY( id )" if exists $cols->{$id_col};
                push @base_cols, "$class_col $schema->{sql}{cid} NOT NULL" if exists $cols->{$class_col};

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

                $do->("CREATE TABLE $table\n(\n  ",
                          join( ",\n  ", @base_cols, map { "$_ $cols->{$_}" } keys %$cols ),
                          "\n)", ($table_type ? " TYPE=$table_type" : '') );
          }

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

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

    $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);

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

sub classids
{
    my ($self) = @_;
    my ($tables, $schema) = @$self;
        my $classes = $schema->{classes};
        # use Data::Dumper;
        return { map { $_ => $classes->{$_}{id} } keys %$classes };
}

package Tangram::Relational::PolySelectTemplate;

sub new
  {
        my $class = shift;
        bless [ @_ ], $class;
  }

sub instantiate
  {
        my ($self, $remote, $xcols, $xfrom, $xwhere) = @_;
        my ($expand, $cols, $from, $where) = @$self;

        $xcols ||= [];
        $xfrom ||= [];

        my @xwhere;

        if (@$xwhere) {
          $xwhere[0] = join ' AND ', @$xwhere;
          $xwhere[0] =~ s[%][%%]g;
        }

        my @tables = $remote->table_ids();

        my $select = sprintf "SELECT %s\n  FROM %s", join(', ', @$cols, @$xcols), join(', ', @$from, @$xfrom);

        $select = sprintf "%s\n  WHERE %s", $select, join(' AND ', @$where, @xwhere)
          if @$where || @$xwhere;

        sprintf $select, map { $tables[$_] } @$expand;
  }

sub extract
{
  my ($self, $row) = @_;
  my $id = shift @$row;
  my $class_id = shift @$row;
  my $slice = $self->[-1]{$class_id} or Carp::croak "unexpected class id '$class_id'";
  my $state = [ @$row[ @$slice ] ];
  splice @$row, 0, @{ $self->[1] } - 2;
  return ($id, $class_id, $state);
}       

1;
1	joko	1.1	# (c) Sound Object Logic 2000-2001
2
3			use strict;
4
5			package Tangram::Relational::TableSet;
6
7			use constant TABLES => 0;
8			use constant SORTED_TABLES => 1;
9			use constant KEY => 2;
10
11			sub new
12			{
13			my $class = shift;
14			my %seen;
15			my @tables = grep { !$seen{$_}++ } @_;
16			my @sorted_tables = sort @tables;
17
18			return bless [ \@tables, \@sorted_tables, "@sorted_tables" ], $class;
19			}
20
21			sub key
22			{
23			return shift->[KEY];
24			}
25
26			sub tables
27			{
28			@{ shift->[TABLES] }
29			}
30
31			sub is_improper_superset
32			{
33			my ($self, $other) = @_;
34			my %other_tables = map { $_ => 1 } $other->tables();
35
36			for my $table ($self->tables()) {
37			delete $other_tables{$table};
38			return 1 if keys(%other_tables) == 0;
39			}
40
41			return 0;
42			}
43
44			package Tangram::Relational::Engine;
45
46			sub new
47			{
48			my ($class, $schema, %opts) = @_;
49
50			my $heterogeneity = { };
51			my $engine = bless { SCHEMA => $schema, HETEROGENEITY => $heterogeneity }, $class;
52
53			if ($opts{layout1}) {
54			$engine->{layout1} = 1;
55			$engine->{TYPE_COL} = $schema->{sql}{class_col} \|\| 'classId';
56			} else {
57			$engine->{TYPE_COL} = $schema->{sql}{class_col} \|\| 'type';
58			}
59
60			for my $class ($schema->all_classes) {
61			$engine->{ROOT_TABLES}{$class->{table}} = 1
62			if $class->is_root();
63			}
64
65			for my $class ($schema->all_classes) {
66
67			$engine->{ROOT_TABLES}{$class->{table}} = 1
68			if $class->is_root();
69
70			next if $class->{abstract};
71
72			my $table_set = $engine->get_table_set($class);
73			my $key = $table_set->key();
74
75			for my $other ($schema->all_classes) {
76			++$heterogeneity->{$key} if my $ss = $engine->get_table_set($other)->is_improper_superset($table_set);
77			my $other_key = $engine->get_table_set($other)->key;
78			}
79			}
80
81			# use Data::Dumper; print Dumper $heterogeneity;
82
83			return $engine;
84			}
85
86			sub get_table_set
87			{
88			my ($self, $class) = @_;
89
90			return $self->{CLASSES}{$class->{name}}{table_set} \|\|= do {
91
92			my @table;
93
94			if ($self->{ROOT_TABLES}{$class->{table}}) {
95			push @table, $class->{table};
96			} else {
97			my $context = { layout1 => $self->{layout1} };
98
99			for my $field ($class->direct_fields()) {
100			if ($field->get_export_cols($context)) {
101			push @table, $class->{table};
102			last;
103			}
104			}
105			}
106
107			Tangram::Relational::TableSet
108			->new((map { $self->get_table_set($_)->tables } $class->direct_bases()), @table );
109			};
110			}
111
112			sub get_parts
113			{
114			my ($self, $class) = @_;
115
116			@{ $self->{CLASSES}{$class->{name}}{PARTS} \|\|= do {
117			my %seen;
118			[ grep { !$seen{ $_->{name} }++ }
119			(map { $self->get_parts($_) } $class->direct_bases()),
120			$class
121			]
122			} }
123			}
124
125			sub get_save_cache
126			{
127			my ($self, $class) = @_;
128
129			return $self->{CLASSES}{$class}{SAVE} \|\|= do {
130
131			my $schema = $self->{SCHEMA};
132			my $id_col = $schema->{sql}{id_col};
133			my $type_col = $self->{TYPE_COL};
134
135			my (%tables, @tables);
136			my (@export_sources, @export_closures);
137
138			my $context = { layout1 => $self->{layout1} };
139
140			my $field_index = 2;
141
142			for my $part ($self->get_parts($class)) {
143			my $table_name = $part->{table};
144
145			$context->{class} = $part;
146
147			my $table = $tables{$table_name} \|\|= do { push @tables, my $table = [ $table_name, [], [] ]; $table };
148
149			for my $field ($part->direct_fields()) {
150
151			my $exporter = $field->get_exporter($context)
152			or next;
153
154			if (ref $exporter) {
155			push @export_closures, $exporter;
156			push @export_sources, 'shift(@closures)->($obj, $context)';
157			} else {
158			push @export_sources, $exporter;
159			}
160
161			my @export_cols = $field->get_export_cols($context);
162			push @{ $table->[1] }, @export_cols;
163			push @{ $table->[2] }, $field_index..($field_index + $#export_cols);
164			$field_index += @export_cols;
165			}
166			}
167
168			my $export_source = join ",\n", @export_sources;
169			my $copy_closures = @export_closures ? ' my @closures = @export_closures;' : '';
170
171			# $Tangram::TRACE = \*STDOUT;
172
173			$export_source = "sub { my (\$obj, \$context) = \@_;$copy_closures\n$export_source }";
174
175			print $Tangram::TRACE "Compiling exporter for $class->{name}...\n$export_source\n"
176			if $Tangram::TRACE;
177
178			# use Data::Dumper; print Dumper \@cols;
179			my $exporter = eval $export_source or die;
180
181			my (@inserts, @updates, @insert_fields, @update_fields);
182
183			for my $table (@tables) {
184			my ($table_name, $cols, $fields) = @$table;
185			my @meta = ( $id_col );
186			my @meta_fields = ( 0 );
187
188			if ($self->{ROOT_TABLES}{$table_name}) {
189			push @meta, $type_col;
190			push @meta_fields, 1;
191			}
192
193			next unless @meta > 1 \|\| @$cols;
194
195			push @inserts, sprintf('INSERT INTO %s (%s) VALUES (%s)',
196			$table_name,
197			join(', ', @meta, @$cols),
198			join(', ', ('?') x (@meta + @$cols)));
199			push @insert_fields, [ @meta_fields, @$fields ];
200
201			if (@$cols) {
202			push @updates, sprintf('UPDATE %s SET %s WHERE %s = ?',
203			$table_name,
204			join(', ', map { "$_ = ?" } @$cols),
205			$id_col);
206			push @update_fields, [ @$fields, 0 ];
207			}
208			}
209
210			{
211			EXPORTER => $exporter,
212			INSERT_FIELDS => \@insert_fields, INSERTS => \@inserts,
213			UPDATE_FIELDS => \@update_fields, UPDATES => \@updates,
214			}
215			};
216			}
217
218			sub get_instance_select
219			{
220			my ($self, $class) = @_;
221
222			return $self->{CLASSES}{$class}{INSTANCE_SELECT} \|\|= do {
223			my $schema = $self->{SCHEMA};
224			my $id_col = $schema->{sql}{id_col};
225			my $context = { engine => $self, schema => $schema, layout1 => $self->{layout1} };
226			my @cols;
227
228			for my $part ($self->get_parts($class)) {
229			my $table = $part->{table};
230			$context->{class} = $part;
231			push @cols, map { "$table.$_" } map { $_->get_import_cols($context) } $part->direct_fields()
232			}
233
234			my ($first_table, @other_tables) = $self->get_table_set($class)->tables();
235
236			sprintf("SELECT %s FROM %s WHERE %s",
237			join(', ', @cols),
238			join(', ', $first_table, @other_tables),
239			join(' AND ', "$first_table.$id_col = ?", map { "$first_table.$id_col = $_.$id_col" } @other_tables));
240			};
241			}
242
243			sub get_polymorphic_select
244			{
245			my ($self, $class, $storage) = @_;
246
247			my $selects = $self->{CLASSES}{$class}{POLYMORPHIC_SELECT} \|\|= do {
248			my $schema = $self->{SCHEMA};
249			my $id_col = $schema->{sql}{id_col};
250			my $type_col = $self->{TYPE_COL};
251			my $context = { engine => $self, schema => $schema, layout1 => $self->{layout1} };
252
253			my $table_set = $self->get_table_set($class);
254			my %base_tables = do { my $ph = 0; map { $_ => $ph++ } $table_set->tables() };
255
256			my %partition;
257
258			$class->for_conforming(sub {
259			my $class = shift;
260			push @{ $partition{ $self->get_table_set($class)->key } }, $class
261			unless $class->{abstract};
262			} );
263
264			my @selects;
265
266			for my $table_set_key (keys %partition) {
267
268			my $mates = $partition{$table_set_key};
269
270			my %slice;
271			my %col_index;
272			my $col_mark = 0;
273			my (@cols, @expand);
274
275			my @tables = $self->get_table_set($mates->[0])->tables();
276
277			my $root_table = $tables[0];
278			push @cols, qualify($id_col, $root_table, \%base_tables, \@expand);
279			push @cols, qualify($type_col, $root_table, \%base_tables, \@expand);
280
281			my %used;
282			$used{$root_table} += 2;
283
284			for my $class (@$mates) {
285			my @slice;
286
287			for my $part ($self->get_parts($class)) {
288			my $table = $part->{table};
289			$context->{class} = $part;
290
291			for my $field ($part->direct_fields()) {
292			my @import_cols = $field->get_import_cols($context);
293			$used{$table} += @import_cols;
294
295			for my $col (@import_cols) {
296			my $qualified_col = "$table.$col";
297			unless (exists $col_index{$qualified_col}) {
298			push @cols, qualify($col, $table, \%base_tables, \@expand);
299			$col_index{$qualified_col} = $col_mark++;
300			}
301
302			push @slice, $col_index{$qualified_col};
303			}
304			}
305			}
306
307			$slice{ $storage->{class2id}{$class->{name}} \|\| $class->{id} } = \@slice; # should be $class->{id} (compat)
308			}
309
310			my @from;
311
312			for my $table (@tables) {
313			next unless $used{$table};
314			if (exists $base_tables{$table}) {
315			push @expand, $base_tables{$table};
316			push @from, "$table t%d";
317			} else {
318			push @from, $table;
319			}
320			}
321
322			my @where = map {
323			qualify($id_col, $root_table, \%base_tables, \@expand) . ' = ' . qualify($id_col, $_, \%base_tables, \@expand)
324			} grep { $used{$_} } @tables[1..$#tables];
325
326			unless (@$mates == $self->{HETEROGENEITY}{$table_set_key}) {
327			push @where, sprintf "%s IN (%s)", qualify($type_col, $root_table, \%base_tables, \@expand),
328			join ', ', map {
329			$storage->{class2id}{$_->{name}} or $_->{id} # try $storage first for compatibility with layout1
330			} @$mates
331			}
332
333			push @selects, Tangram::Relational::PolySelectTemplate->new(\@expand, \@cols, \@from, \@where, \%slice);
334			}
335
336			\@selects;
337			};
338
339			return @$selects;
340			}
341
342			sub qualify
343			{
344			my ($col, $table, $ph, $expand) = @_;
345
346			if (exists $ph->{$table}) {
347			push @$expand, $ph->{$table};
348			return "t%d.$col";
349			} else {
350			return "$table.$col";
351			}
352			}
353
354			sub get_import_cache
355			{
356			my ($self, $class) = @_;
357
358			return $self->{CLASSES}{$class}{IMPORTER} \|\|=
359			do {
360			my $schema = $self->{SCHEMA};
361
362			my $context = { schema => $schema, layout1 => $self->{layout1} };
363
364			my (@import_sources, @import_closures);
365
366			for my $part ($self->get_parts($class)) {
367			my $table_name = $part->{table};
368
369			$context->{class} = $part;
370
371			for my $field ($part->direct_fields) {
372
373			my $importer = $field->get_importer($context)
374			or next;
375
376			if (ref $importer) {
377			push @import_closures, $importer;
378			push @import_sources, 'shift(@closures)->($obj, $row, $context)';
379			} else {
380			push @import_sources, $importer;
381			}
382			}
383			}
384
385			my $import_source = join ";\n", @import_sources;
386			my $copy_closures = @import_closures ? ' my @closures = @import_closures;' : '';
387
388			# $Tangram::TRACE = \*STDOUT;
389
390			$import_source = "sub { my (\$obj, \$row, \$context) = \@_;$copy_closures\n$import_source }";
391
392			print $Tangram::TRACE "Compiling importer for $class->{name}...\n$import_source\n"
393			if $Tangram::TRACE;
394
395			# use Data::Dumper; print Dumper \@cols;
396			eval $import_source or die;
397			};
398			}
399
400			sub get_deletes
401			{
402			my ($self, $class) = @_;
403
404			return $self->{CLASSES}{$class}{DELETES} \|\|= do {
405			my $id_col = $self->{SCHEMA}{sql}{id_col};
406			[ map { "DELETE FROM $_ WHERE $id_col = ?" } $self->get_table_set($class)->tables() ]
407			};
408			}
409
410			sub deploy
411			{
412			my ($self, $out) = @_;
413			$self->relational_schema()->deploy($out);
414			}
415
416			sub retreat
417			{
418			my ($self, $out) = @_;
419			$self->relational_schema()->retreat($out);
420			}
421
422			sub get_deploy_info
423			{
424			my ($self) = @_;
425			return { LAYOUT => 2, ENGINE => ref($self), ENGINE_LAYOUT => 1 };
426			}
427
428			sub relational_schema
429			{
430			my ($self) = @_;
431
432			my $schema = $self->{SCHEMA};
433			my $classes = $schema->{classes};
434			my $tables = {};
435
436			foreach my $class (keys %{$schema->{classes}}) {
437
438			my $classdef = $classes->{$class};
439			my $tabledef = $tables->{ $classdef->{table} } \|\|= {};
440			my $cols = $tabledef->{COLS} \|\|= {};
441
442			$cols->{ $schema->{sql}{id_col} } = $schema->{sql}{id};
443
444			$cols->{ $schema->{sql}{class_col} \|\| 'type' } = $schema->{sql}{cid} if $self->{ROOT_TABLES}{$classdef->{table}};
445	joko	1.2
446			$tables->{$class}->{SQL} = $classdef->{sql} if $classdef->{sql};
447	joko	1.1
448			foreach my $typetag (keys %{$classdef->{members}})
449			{
450			my $members = $classdef->{members}{$typetag};
451			my $type = $schema->{types}{$typetag};
452
453			$type->coldefs($tabledef->{COLS}, $members, $schema, $class, $tables);
454			}
455			}
456
457			delete @$tables{ grep { 1 == keys %{ $tables->{$_}{COLS} } } keys %$tables };
458
459			return bless [ $tables, $self ], 'Tangram::RelationalSchema';
460			}
461
462			sub Tangram::Scalar::_coldefs
463			{
464			my ($self, $cols, $members, $sql, $schema) = @_;
465
466			for my $def (values %$members)
467			{
468			$cols->{ $def->{col} } = $def->{sql} \|\| "$sql $schema->{sql}{default_null}";
469			}
470			}
471			sub Tangram::Integer::coldefs
472			{
473			my ($self, $cols, $members, $schema) = @_;
474			$self->_coldefs($cols, $members, 'INT', $schema);
475			}
476
477			sub Tangram::Real::coldefs
478			{
479			my ($self, $cols, $members, $schema) = @_;
480			$self->_coldefs($cols, $members, 'REAL', $schema);
481			}
482
483			# sub Tangram::Ref::coldefs
484			# {
485			# my ($self, $cols, $members, $schema) = @_;
486
487			# for my $def (values %$members)
488			# {
489			# $cols->{ $def->{col} } = !exists($def->{null}) \|\| $def->{null}
490			# ? "$schema->{sql}{id} $schema->{sql}{default_null}"
491			# : $schema->{sql}{id};
492			# }
493			# }
494
495			sub Tangram::String::coldefs
496			{
497			my ($self, $cols, $members, $schema) = @_;
498			$self->_coldefs($cols, $members, 'VARCHAR(255)', $schema);
499			}
500
501			sub Tangram::Set::coldefs
502			{
503			my ($self, $cols, $members, $schema, $class, $tables) = @_;
504
505			foreach my $member (values %$members)
506			{
507			$tables->{ $member->{table} }{COLS} =
508			{
509			$member->{coll} => $schema->{sql}{id},
510			$member->{item} => $schema->{sql}{id},
511			};
512			}
513			}
514
515			sub Tangram::IntrSet::coldefs
516			{
517			my ($self, $cols, $members, $schema, $class, $tables) = @_;
518
519			foreach my $member (values %$members)
520			{
521			my $table = $tables->{ $schema->{classes}{$member->{class}}{table} } \|\|= {};
522			$table->{COLS}{$member->{coll}} = "$schema->{sql}{id} $schema->{sql}{default_null}";
523			}
524			}
525
526			sub Tangram::Array::coldefs
527			{
528			my ($self, $cols, $members, $schema, $class, $tables) = @_;
529
530			foreach my $member (values %$members)
531			{
532			$tables->{ $member->{table} }{COLS} =
533			{
534			$member->{coll} => $schema->{sql}{id},
535			$member->{item} => $schema->{sql}{id},
536			$member->{slot} => "INT $schema->{sql}{default_null}"
537			};
538			}
539			}
540
541			sub Tangram::Hash::coldefs
542			{
543			my ($self, $cols, $members, $schema, $class, $tables) = @_;
544
545			foreach my $member (values %$members)
546			{
547			$tables->{ $member->{table} }{COLS} =
548			{
549			$member->{coll} => $schema->{sql}{id},
550			$member->{item} => $schema->{sql}{id},
551			$member->{slot} => "VARCHAR(255) $schema->{sql}{default_null}"
552			};
553			}
554			}
555
556			sub Tangram::IntrArray::coldefs
557			{
558			my ($self, $cols, $members, $schema, $class, $tables) = @_;
559
560			foreach my $member (values %$members)
561			{
562			my $table = $tables->{ $schema->{classes}{$member->{class}}{table} } \|\|= {};
563			$table->{COLS}{$member->{coll}} = "$schema->{sql}{id} $schema->{sql}{default_null}";
564			$table->{COLS}{$member->{slot}} = "INT $schema->{sql}{default_null}";
565			}
566			}
567
568			sub Tangram::HashRef::coldefs
569			{
570			#later
571			}
572
573			sub Tangram::BackRef::coldefs
574			{
575			return ();
576			}
577
578			package Tangram::RelationalSchema;
579
580			sub _deploy_do
581			{
582			my $output = shift;
583
584			return ref($output) && eval { $output->isa('DBI::db') }
585			? sub { print $Tangram::TRACE @_, "\n" if $Tangram::TRACE;
586			$output->do( join '', @_ ); }
587			: sub { print $output @_, ";\n\n" };
588			}
589
590			sub deploy
591			{
592			my ($self, $output) = @_;
593			my ($tables, $engine) = @$self;
594			my $schema = $engine->{SCHEMA};
595
596			$output \|\|= \*STDOUT;
597
598			my $do = _deploy_do($output);
599
600			foreach my $table (sort keys %$tables)
601			{
602			my $def = $tables->{$table};
603			my $cols = $def->{COLS};
604	joko	1.2	my $sql = $def->{SQL};
605	joko	1.1
606			my @base_cols;
607			my $id_col = $schema->{sql}{id_col};
608			my $class_col = $schema->{sql}{class_col} \|\| 'type';
609	joko	1.2	my $table_type = $sql->{table_type} \|\| $schema->{sql}{table_type};
610	joko	1.1
611			push @base_cols, "$id_col $schema->{sql}{id} NOT NULL,\n PRIMARY KEY( id )" if exists $cols->{$id_col};
612			push @base_cols, "$class_col $schema->{sql}{cid} NOT NULL" if exists $cols->{$class_col};
613
614			delete @$cols{$id_col};
615			delete @$cols{$class_col};
616
617			$do->("CREATE TABLE $table\n(\n ",
618			join( ",\n ", @base_cols, map { "$_ $cols->{$_}" } keys %$cols ),
619	joko	1.2	"\n)", ($table_type ? " TYPE=$table_type" : '') );
620	joko	1.1	}
621
622	joko	1.2	my $table_type = $schema->{sql}{table_type};
623			my $control_type = ($table_type ? " TYPE=$table_type" : '');
624	joko	1.1	my $control = $schema->{control};
625
626			$do->( <<SQL );
627			CREATE TABLE $control
628			(
629			layout INTEGER NOT NULL,
630			engine VARCHAR(255),
631			engine_layout INTEGER,
632			mark INTEGER NOT NULL
633			)
634	joko	1.2	$control_type
635	joko	1.1	SQL
636
637			my $info = $engine->get_deploy_info();
638			my ($l) = split '\.', $Tangram::VERSION;
639
640			$do->("INSERT INTO $control (layout, engine, engine_layout, mark) VALUES ($info->{LAYOUT}, '$info->{ENGINE}', $info->{ENGINE_LAYOUT}, 0)");
641			}
642
643			sub retreat
644			{
645			my ($self, $output) = @_;
646			my ($tables, $engine) = @$self;
647			my $schema = $engine->{SCHEMA};
648
649			$output \|\|= \*STDOUT;
650
651			my $do = _deploy_do($output);
652
653			for my $table (sort keys %$tables, $schema->{control})
654			{
655			$do->( "DROP TABLE $table" );
656			}
657			}
658
659			sub classids
660			{
661			my ($self) = @_;
662			my ($tables, $schema) = @$self;
663			my $classes = $schema->{classes};
664			# use Data::Dumper;
665			return { map { $_ => $classes->{$_}{id} } keys %$classes };
666			}
667
668			package Tangram::Relational::PolySelectTemplate;
669
670			sub new
671			{
672			my $class = shift;
673			bless [ @_ ], $class;
674			}
675
676			sub instantiate
677			{
678			my ($self, $remote, $xcols, $xfrom, $xwhere) = @_;
679			my ($expand, $cols, $from, $where) = @$self;
680
681			$xcols \|\|= [];
682			$xfrom \|\|= [];
683
684			my @xwhere;
685
686			if (@$xwhere) {
687			$xwhere[0] = join ' AND ', @$xwhere;
688			$xwhere[0] =~ s[%][%%]g;
689			}
690
691			my @tables = $remote->table_ids();
692
693			my $select = sprintf "SELECT %s\n FROM %s", join(', ', @$cols, @$xcols), join(', ', @$from, @$xfrom);
694
695			$select = sprintf "%s\n WHERE %s", $select, join(' AND ', @$where, @xwhere)
696			if @$where \|\| @$xwhere;
697
698			sprintf $select, map { $tables[$_] } @$expand;
699			}
700
701			sub extract
702			{
703			my ($self, $row) = @_;
704			my $id = shift @$row;
705			my $class_id = shift @$row;
706			my $slice = $self->[-1]{$class_id} or Carp::croak "unexpected class id '$class_id'";
707			my $state = [ @$row[ @$slice ] ];
708			splice @$row, 0, @{ $self->[1] } - 2;
709			return ($id, $class_id, $state);
710			}
711
712			1;
MailToCvsAdmin">MailToCvsAdmin	ViewVC Help
Powered by ViewVC 1.1.26