/[cvs]/nfo/perl/libs/Tangram/Relational/Engine.pm
ViewVC logotype

Annotation of /nfo/perl/libs/Tangram/Relational/Engine.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (hide annotations)
Fri Nov 15 11:44:49 2002 UTC (21 years, 7 months ago) by joko
Branch: MAIN
+ initial check in

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    
440     my $tabledef = $tables->{ $classdef->{table} } ||= {};
441     my $cols = $tabledef->{COLS} ||= {};
442    
443     $cols->{ $schema->{sql}{id_col} } = $schema->{sql}{id};
444    
445     $cols->{ $schema->{sql}{class_col} || 'type' } = $schema->{sql}{cid} if $self->{ROOT_TABLES}{$classdef->{table}};
446    
447     foreach my $typetag (keys %{$classdef->{members}})
448     {
449     my $members = $classdef->{members}{$typetag};
450     my $type = $schema->{types}{$typetag};
451    
452     $type->coldefs($tabledef->{COLS}, $members, $schema, $class, $tables);
453     }
454     }
455    
456     delete @$tables{ grep { 1 == keys %{ $tables->{$_}{COLS} } } keys %$tables };
457    
458     return bless [ $tables, $self ], 'Tangram::RelationalSchema';
459     }
460    
461     sub Tangram::Scalar::_coldefs
462     {
463     my ($self, $cols, $members, $sql, $schema) = @_;
464    
465     for my $def (values %$members)
466     {
467     $cols->{ $def->{col} } = $def->{sql} || "$sql $schema->{sql}{default_null}";
468     }
469     }
470     sub Tangram::Integer::coldefs
471     {
472     my ($self, $cols, $members, $schema) = @_;
473     $self->_coldefs($cols, $members, 'INT', $schema);
474     }
475    
476     sub Tangram::Real::coldefs
477     {
478     my ($self, $cols, $members, $schema) = @_;
479     $self->_coldefs($cols, $members, 'REAL', $schema);
480     }
481    
482     # sub Tangram::Ref::coldefs
483     # {
484     # my ($self, $cols, $members, $schema) = @_;
485    
486     # for my $def (values %$members)
487     # {
488     # $cols->{ $def->{col} } = !exists($def->{null}) || $def->{null}
489     # ? "$schema->{sql}{id} $schema->{sql}{default_null}"
490     # : $schema->{sql}{id};
491     # }
492     # }
493    
494     sub Tangram::String::coldefs
495     {
496     my ($self, $cols, $members, $schema) = @_;
497     $self->_coldefs($cols, $members, 'VARCHAR(255)', $schema);
498     }
499    
500     sub Tangram::Set::coldefs
501     {
502     my ($self, $cols, $members, $schema, $class, $tables) = @_;
503    
504     foreach my $member (values %$members)
505     {
506     $tables->{ $member->{table} }{COLS} =
507     {
508     $member->{coll} => $schema->{sql}{id},
509     $member->{item} => $schema->{sql}{id},
510     };
511     }
512     }
513    
514     sub Tangram::IntrSet::coldefs
515     {
516     my ($self, $cols, $members, $schema, $class, $tables) = @_;
517    
518     foreach my $member (values %$members)
519     {
520     my $table = $tables->{ $schema->{classes}{$member->{class}}{table} } ||= {};
521     $table->{COLS}{$member->{coll}} = "$schema->{sql}{id} $schema->{sql}{default_null}";
522     }
523     }
524    
525     sub Tangram::Array::coldefs
526     {
527     my ($self, $cols, $members, $schema, $class, $tables) = @_;
528    
529     foreach my $member (values %$members)
530     {
531     $tables->{ $member->{table} }{COLS} =
532     {
533     $member->{coll} => $schema->{sql}{id},
534     $member->{item} => $schema->{sql}{id},
535     $member->{slot} => "INT $schema->{sql}{default_null}"
536     };
537     }
538     }
539    
540     sub Tangram::Hash::coldefs
541     {
542     my ($self, $cols, $members, $schema, $class, $tables) = @_;
543    
544     foreach my $member (values %$members)
545     {
546     $tables->{ $member->{table} }{COLS} =
547     {
548     $member->{coll} => $schema->{sql}{id},
549     $member->{item} => $schema->{sql}{id},
550     $member->{slot} => "VARCHAR(255) $schema->{sql}{default_null}"
551     };
552     }
553     }
554    
555     sub Tangram::IntrArray::coldefs
556     {
557     my ($self, $cols, $members, $schema, $class, $tables) = @_;
558    
559     foreach my $member (values %$members)
560     {
561     my $table = $tables->{ $schema->{classes}{$member->{class}}{table} } ||= {};
562     $table->{COLS}{$member->{coll}} = "$schema->{sql}{id} $schema->{sql}{default_null}";
563     $table->{COLS}{$member->{slot}} = "INT $schema->{sql}{default_null}";
564     }
565     }
566    
567     sub Tangram::HashRef::coldefs
568     {
569     #later
570     }
571    
572     sub Tangram::BackRef::coldefs
573     {
574     return ();
575     }
576    
577     package Tangram::RelationalSchema;
578    
579     sub _deploy_do
580     {
581     my $output = shift;
582    
583     return ref($output) && eval { $output->isa('DBI::db') }
584     ? sub { print $Tangram::TRACE @_, "\n" if $Tangram::TRACE;
585     $output->do( join '', @_ ); }
586     : sub { print $output @_, ";\n\n" };
587     }
588    
589     sub deploy
590     {
591     my ($self, $output) = @_;
592     my ($tables, $engine) = @$self;
593     my $schema = $engine->{SCHEMA};
594    
595     $output ||= \*STDOUT;
596    
597     my $do = _deploy_do($output);
598    
599     foreach my $table (sort keys %$tables)
600     {
601     my $def = $tables->{$table};
602     my $cols = $def->{COLS};
603    
604     my @base_cols;
605    
606     my $id_col = $schema->{sql}{id_col};
607     my $class_col = $schema->{sql}{class_col} || 'type';
608    
609     push @base_cols, "$id_col $schema->{sql}{id} NOT NULL,\n PRIMARY KEY( id )" if exists $cols->{$id_col};
610     push @base_cols, "$class_col $schema->{sql}{cid} NOT NULL" if exists $cols->{$class_col};
611    
612     delete @$cols{$id_col};
613     delete @$cols{$class_col};
614    
615     $do->("CREATE TABLE $table\n(\n ",
616     join( ",\n ", @base_cols, map { "$_ $cols->{$_}" } keys %$cols ),
617     "\n)" );
618     }
619    
620     my $control = $schema->{control};
621    
622     $do->( <<SQL );
623     CREATE TABLE $control
624     (
625     layout INTEGER NOT NULL,
626     engine VARCHAR(255),
627     engine_layout INTEGER,
628     mark INTEGER NOT NULL
629     )
630     SQL
631    
632     my $info = $engine->get_deploy_info();
633     my ($l) = split '\.', $Tangram::VERSION;
634    
635     $do->("INSERT INTO $control (layout, engine, engine_layout, mark) VALUES ($info->{LAYOUT}, '$info->{ENGINE}', $info->{ENGINE_LAYOUT}, 0)");
636     }
637    
638     sub retreat
639     {
640     my ($self, $output) = @_;
641     my ($tables, $engine) = @$self;
642     my $schema = $engine->{SCHEMA};
643    
644     $output ||= \*STDOUT;
645    
646     my $do = _deploy_do($output);
647    
648     for my $table (sort keys %$tables, $schema->{control})
649     {
650     $do->( "DROP TABLE $table" );
651     }
652     }
653    
654     sub classids
655     {
656     my ($self) = @_;
657     my ($tables, $schema) = @$self;
658     my $classes = $schema->{classes};
659     # use Data::Dumper;
660     return { map { $_ => $classes->{$_}{id} } keys %$classes };
661     }
662    
663     package Tangram::Relational::PolySelectTemplate;
664    
665     sub new
666     {
667     my $class = shift;
668     bless [ @_ ], $class;
669     }
670    
671     sub instantiate
672     {
673     my ($self, $remote, $xcols, $xfrom, $xwhere) = @_;
674     my ($expand, $cols, $from, $where) = @$self;
675    
676     $xcols ||= [];
677     $xfrom ||= [];
678    
679     my @xwhere;
680    
681     if (@$xwhere) {
682     $xwhere[0] = join ' AND ', @$xwhere;
683     $xwhere[0] =~ s[%][%%]g;
684     }
685    
686     my @tables = $remote->table_ids();
687    
688     my $select = sprintf "SELECT %s\n FROM %s", join(', ', @$cols, @$xcols), join(', ', @$from, @$xfrom);
689    
690     $select = sprintf "%s\n WHERE %s", $select, join(' AND ', @$where, @xwhere)
691     if @$where || @$xwhere;
692    
693     sprintf $select, map { $tables[$_] } @$expand;
694     }
695    
696     sub extract
697     {
698     my ($self, $row) = @_;
699     my $id = shift @$row;
700     my $class_id = shift @$row;
701     my $slice = $self->[-1]{$class_id} or Carp::croak "unexpected class id '$class_id'";
702     my $state = [ @$row[ @$slice ] ];
703     splice @$row, 0, @{ $self->[1] } - 2;
704     return ($id, $class_id, $state);
705     }
706    
707     1;

MailToCvsAdmin">MailToCvsAdmin
ViewVC Help
Powered by ViewVC 1.1.26 RSS 2.0 feed