1package Tangram::Relational::Engine::Class;
2
3use strict;
4use Tangram::Schema;
5
6use vars qw(@ISA);
7@ISA = qw( Tangram::Schema::Node );
8use Carp qw(confess);
9
10sub new {
11    bless { }, shift;
12}
13
14sub fracture {
15    my ($self) = @_;
16    delete $self->{BASES};
17    delete $self->{SPECS};
18}
19
20sub initialize {
21    my ($self, $engine, $class, $mapping) = @_;
22    ref($self->{CLASS} = $class)
23	&& UNIVERSAL::isa($class, "Tangram::Schema::Class")
24	    or confess "not class but $class";
25    $self->{MAPPING} = $mapping;
26    $self->{BASES} = [
27		      map { $engine->get_class_engine($_) }
28		      $class->get_bases()
29		     ];
30    $self->{SPECS} = [
31		      map { $engine->get_class_engine($_) }
32		      $class->get_specs()
33		     ];
34    $self->{ID_COL} = $engine->{SCHEMA}{sql}{id_col};
35}
36
37sub get_instance_select {
38    my ($self, $engine) = @_;
39
40    return $self->{INSTANCE_SELECT} ||= do {
41
42	my $schema = $engine->{SCHEMA};
43	my $id_col = $schema->{sql}{id_col};
44
45	my $context = {
46		       engine => $engine,
47		       schema => $schema,
48		       layout1 => $engine->{layout1}
49		      };
50
51	my (@tables, %seen, @cols, $root);
52
53	$self->for_composing
54	    (
55	     sub {
56		 my ($part) = @_;
57		 $root ||= $part;
58		 $context->{class} = $part->{CLASS};
59		 push @cols,
60		     (
61		      map {
62			  my ($table, $col) = @$_;
63			  push @tables, $table unless $seen{$table}++;
64			  "$table.$col"
65		      }
66		      $part->{MAPPING}->get_import_cols($context)
67		     );
68		 }
69	    );
70
71	unless (@tables) {
72	    # in case the class has absolutely no state at all...
73	    # XXX - not reached by the test suite
74	    @cols = $id_col;
75	    @tables = $root->{MAPPING}->get_table;
76	}
77
78	my $first_table = shift @tables;
79
80	sprintf("SELECT\n    %s\nFROM\n    %s\nWHERE\n    %s",
81		join(",\n    ", @cols),
82		join(",\n    ", $first_table, @tables),
83		join("\tAND\n    ", "$first_table.$id_col = ?",
84		     (map { "$first_table.$id_col = $_.$id_col" }
85		      @tables)
86		    )
87	       );
88  };
89}
90
91sub get_insert_statements {
92  my ($self, $engine) = @_;
93  return @{ $self->get_save_cache($engine)->{INSERTS} };
94}
95
96sub get_insert_fields {
97  my ($self, $engine) = @_;
98  return @{ $self->get_save_cache($engine)->{INSERT_FIELDS} };
99}
100
101sub get_update_statements {
102  my ($self, $engine) = @_;
103  return @{ $self->get_save_cache($engine)->{UPDATES} };
104}
105
106sub get_update_fields {
107  my ($self, $engine) = @_;
108  return @{ $self->get_save_cache($engine)->{UPDATE_FIELDS} };
109}
110
111sub get_save_cache {
112
113    my ($class, $engine) = @_;
114
115    return $class->{SAVE} ||= do {
116
117	my $schema = $engine->{SCHEMA};
118	my $id_col = $schema->{sql}{id_col};
119	my $type_col = $engine->{TYPE_COL};
120
121	my (%tables, @tables);
122	my (@export_sources, @export_closures);
123
124	my $context = { layout1 => $engine->{layout1} };
125
126	my $field_index = 2;
127
128	$class->for_composing
129	    (sub {
130		 my ($part) = @_;
131
132		 my $table_name =  $part->{MAPPING}{table};
133		 my $table = $tables{$table_name}
134		     ||= do {
135			 push @tables,
136			     my $table = [ $table_name, [], [] ];
137			 $table
138		     };
139
140		 $context->{class} = $part;
141
142		 for my $field ($part->{MAPPING}->get_direct_fields())
143		 {
144		     my @export_cols =
145			 $field->get_export_cols($context);
146
147		     push @{ $table->[1] }, @export_cols;
148		     push @{ $table->[2] },
149			 $field_index..($field_index + $#export_cols);
150		     $field_index += @export_cols;
151		 }
152	     });
153
154	my (@inserts, @updates, @insert_fields, @update_fields);
155
156	for my $table (@tables) {
157	    my ($table_name, $cols, $fields) = @$table;
158	    my @meta = ( $id_col );
159	    my @meta_fields = ( 0 );
160
161	    if ($engine->{ROOT_TABLES}{$table_name}) {
162		push @meta, $type_col;
163		push @meta_fields, 1;
164	    }
165
166	    next unless @meta > 1 || @$cols;
167
168	    push @inserts, sprintf("INSERT INTO %s\n    (%s)\nVALUES\n    (%s)",
169				   $table_name,
170				   join(', ', @meta, @$cols),
171				   join(', ', ('?') x (@meta + @$cols)));
172	    push @insert_fields, [ @meta_fields, @$fields ];
173
174	    if (@$cols) {
175		push @updates, sprintf("UPDATE\n    %s\nSET\n%s\nWHERE\n    %s = ?",
176				       $table_name,
177				       join(",\n", map { "    $_ = ?" } @$cols),
178				       $id_col);
179		push @update_fields, [ @$fields, 0 ];
180	    }
181	}
182
183	{
184	    INSERT_FIELDS => \@insert_fields, INSERTS => \@inserts,
185	    UPDATE_FIELDS => \@update_fields, UPDATES => \@updates,
186	}
187    };
188}
189
190sub get_deletes {
191
192    my ($self, $engine) = @_;
193
194    return @{ $self->{DELETE} ||= do {
195	my $schema = $engine->{SCHEMA};
196	my $context = {
197		       engine => $engine,
198		       schema => $schema,
199		       layout1 => $engine->{layout1}
200		      };
201	my (@tables, %seen);
202
203	$self->for_composing
204	    (sub {
205		 my ($part) = @_;
206		 my $mapping = $part->{MAPPING};
207
208		 my $home_table = $mapping->{table};
209		 push @tables, $home_table
210		     if $mapping->is_root() && !$seen{$home_table}++;
211
212		 $context->{class} = $part->{CLASS};
213
214		 for my $qcol ($mapping->get_export_cols($context)) {
215		     my ($table) = @$qcol;
216		     push @tables, $table unless $seen{$table}++;
217		 }
218	     });
219
220	  my $id_col = $engine->{SCHEMA}{sql}{id_col};
221
222	  [ map { "DELETE FROM $_ WHERE $id_col = ?" } @tables ]
223      } };
224}
225
226sub get_table_set {
227    my ($self, $engine) = @_;
228
229    # return the TableSet on which the object's state resides
230
231    # It doesn't include tables resulting solely from an intrusion.
232    # Tables that carry only meta-information are also included.
233
234    return $self->{TABLE_SET} ||= do {
235
236	my $mapping = $self->{MAPPING};
237	my $home_table = $mapping->{table};
238	my $context = {
239		       layout1 => $engine->{layout1},
240		       class => $self->{CLASS}
241		      };
242
243	my @table = map { $_->[0] }
244	    $mapping->get_export_cols($context);
245
246	push @table, $home_table
247	    if $engine->{ROOT_TABLES}{$home_table};
248
249	Tangram::Relational::TableSet
250		->new((map { $_->get_table_set($engine)->tables }
251		       $self->direct_bases()), @table );
252    };
253}
254
255sub get_polymorphic_select {
256    my ($self, $engine, $storage) = @_;
257
258    my $selects = $self->{POLYMORPHIC_SELECT} ||= do {
259
260	my $schema = $engine->{SCHEMA};
261	my $id_col = $schema->{sql}{id_col};
262	my $type_col = $engine->{TYPE_COL};
263	my $context = {
264		       engine => $engine,
265		       schema => $schema,
266		       layout1 => $engine->{layout1}
267		      };
268
269	my $table_set = $self->get_table_set($engine);
270	my %base_tables = do {
271	    my $ph = 0; map { $_ => $ph++ } $table_set->tables()
272	};
273
274	my %partition;
275
276	$self->for_conforming
277	    (sub {
278		 my $conforming = shift;
279		 my $key = $conforming->get_table_set($engine)->key;
280		 push @{ $partition{ $key } }, $conforming
281		     unless $conforming->{CLASS}{abstract};
282	     });
283
284	my @selects;
285
286	for my $table_set_key (keys %partition) {
287
288	    my $mates = $partition{$table_set_key};
289	    my $table_set = $mates->[0]->get_table_set($engine);
290	    my @tables = $table_set->tables();
291
292	    my %slice;
293	    my %col_index;
294	    my $col_mark = 0;
295	    my (@cols, @expand);
296
297	    my $root_table = $tables[0];
298
299	    push @cols, qualify($id_col, $root_table,
300				\%base_tables, \@expand);
301	    push @cols, qualify($type_col, $root_table,
302				\%base_tables, \@expand);
303
304	    my %used;
305	    $used{$root_table} += 2;
306
307	    for my $mate (@$mates) {
308		my @slice;
309
310		$mate->for_composing
311		    (sub {
312			 my ($composing) = @_;
313			 my $table = $composing->{MAPPING}{table};
314			 $context->{class} = $composing;
315			 my @direct_fields =
316			     $composing->{MAPPING}->get_direct_fields();
317			 for my $field (@direct_fields) {
318			     my @import_cols =
319				 $field->get_import_cols($context);
320
321			     $used{$table} += @import_cols;
322
323			     for my $col (@import_cols) {
324				 my $qualified_col = "$table.$col";
325				 unless (exists $col_index{$qualified_col}) {
326				     push @cols, qualify($col, $table,
327							 \%base_tables,
328							 \@expand);
329				     $col_index{$qualified_col} = $col_mark++;
330				 }
331
332				 push @slice, $col_index{$qualified_col};
333			     }
334			 }
335		     });
336
337		$slice{ $storage->{class2id}{$mate->{CLASS}{name}}
338			|| $mate->{MAPPING}{id} }
339		    = \@slice; # should be $mate->{id} (compat)
340	    }
341
342	    my @from;
343
344	    for my $table (@tables) {
345		next unless $used{$table};
346		if (exists $base_tables{$table}) {
347		    push @expand, $base_tables{$table};
348		    push @from, "$table t%d";
349		} else {
350		    push @from, $table;
351		}
352	    }
353
354	    my @where =
355		(map {
356		    (qualify($id_col, $root_table, \%base_tables,
357			     \@expand)
358		     . ' = '
359		     . qualify($id_col, $_, \%base_tables, \@expand) )
360		}
361		 grep { $used{$_} }
362		 @tables[1..$#tables]
363		);
364
365	    unless ( ($storage->{compat} and $storage->{compat} le "2.08")
366		     or
367		     @$mates == $engine->get_heterogeneity($table_set))
368	    {
369		my @type_ids = (map {
370		    # try $storage first for compatibility
371		    # with layout1
372		    $storage->{class2id}{$_->{CLASS}{name}}
373			or $_->{MAPPING}{id}
374		    } @$mates);
375
376		my $column = qualify($type_col, $root_table, \%base_tables,
377				     \@expand);
378		if ( @type_ids == 1 ) {
379		    push @where, "$column = @type_ids";
380		} else {
381		    push @where, "$column IN (". (join ', ', @type_ids). ")";
382		}
383	    }
384
385	    push @selects,
386		Tangram::Relational::PolySelectTemplate
387			->new(\@expand, \@cols, \@from, \@where,
388			      \%slice);
389	  }
390
391	\@selects;
392    };
393
394    return @$selects;
395}
396
397sub qualify {
398    my ($col, $table, $ph, $expand) = @_;
399
400    if (exists $ph->{$table}) {
401	push @$expand, $ph->{$table};
402	return "t%d.$col";
403    } else {
404	return "$table.$col";
405    }
406}
407
408# XXX - never reached (?)
409sub get_exporter {
410    my ($self, $context) = @_;
411
412    return $self->{EXPORTER} ||= do {
413
414	my (@export_sources, @export_closures);
415
416	$self->for_composing
417	    (sub {
418		 my ($composing) = @_;
419
420		 my $class = $composing->{CLASS};
421		 $context->{class} = $class;
422
423		 for my $field ($composing->{MAPPING}->get_direct_fields()) {
424		     if (my $exporter = $field->get_exporter($context)) {
425			 if (ref $exporter) {
426			     push @export_closures, $exporter;
427			     push @export_sources,
428				 'shift(@closures)->($obj, $context)';
429			 } else {
430			     push @export_sources, $exporter;
431			 }
432		     }
433		 }
434	     });
435
436	my $export_source = join ",\n", @export_sources;
437	my $copy_closures =
438	    ( @export_closures ? ' my @closures = @export_closures;' : '' );
439
440	$export_source = ("sub { my (\$obj, \$context) = \@_;"
441			  ."$copy_closures\n$export_source }");
442
443	print $Tangram::TRACE ("Compiling exporter for $self->{name}..."
444			       ."\n$export_source\n")
445	    if $Tangram::TRACE;
446
447	eval $export_source or die;
448    }
449}
450
451# XXX - never reached (?)
452sub get_importer {
453  my ($self, $context) = @_;
454
455  return $self->{IMPORTER} ||= do {
456	my (@import_sources, @import_closures);
457
458	$self->for_composing
459	    (
460	     sub {
461		 my ($composing) = @_;
462
463		 my $class = $composing->{CLASS};
464		 $context->{class} = $class;
465
466		 for my $field ($composing->{MAPPING}->get_direct_fields()) {
467
468		     my $importer = $field->get_importer($context)
469			 or next;
470
471		     if (ref $importer) {
472			 push @import_closures, $importer;
473			 push @import_sources,
474			     'shift(@closures)->($obj, $row, $context)';
475		     } else {
476			 push @import_sources, $importer;
477		     }
478		 }
479	     } );
480
481	my $import_source = join ";\n", @import_sources;
482	my $copy_closures =
483	    ( @import_closures
484	      ? ' my @closures = @import_closures;'
485	      : '' );
486
487	# $Tangram::TRACE = \*STDOUT;
488
489	$import_source = ("sub { my (\$obj, \$row, \$context) = \@_;"
490			  ."$copy_closures\n$import_source }");
491
492	print $Tangram::TRACE ("Compiling importer for $self->{name}:"
493			       ."\n$import_source\n")
494	  if $Tangram::TRACE;
495
496	# use Data::Dumper; print Dumper \@cols;
497	eval $import_source or die;
498  };
499}
500
5011;
502