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