package Tangram::Schema::Node;
# base class for Tangram::Class in Tangram::Schema (now
# Tangram::Schema::Class) and Tangram::Relational::Engine::Class
use strict;
sub get_bases
{
@{ shift->{BASES} }
}
*direct_bases = \&get_bases;
sub get_specs
{
@{ shift->{SPECS} }
}
sub for_conforming
{
my ($class, $fun, @args) = @_;
my $done = Set::Object->new;
my $traverse;
$traverse = sub {
my $class = shift;
return if $done->includes($class);
$done->insert($class);
$fun->($class, @args);
foreach my $derived (@{ $class->{SPECS} }) {
$traverse->($derived);
}
};
$traverse->($class);
}
#---------------------------------------------------------------------
# Tangram::Node->for_composing($closure, @_)
#
# Runs the given closure once for this class, and all its superclasses
# listed in the schema as $class->{BASES}
#
#---------------------------------------------------------------------
sub for_composing
{
my ($class, $fun, @args) = @_;
my $done = Set::Object->new;
my $traverse;
$traverse = sub {
my $class = shift;
return if $done->includes($class);
$done->insert($class);
foreach my $base (@{ $class->{BASES} }) {
$traverse->($base);
}
$fun->($class, @args);
};
$traverse->($class);
}
sub get_exporter {
my ($self, $context) = @_;
return $self->{EXPORTER} ||= do {
my (@export_sources, @export_closures);
$self->for_composing
( sub {
my ($part) = @_;
$context->{class} = $part;
for my $field ($part->direct_fields()) {
if (my $exporter = $field->get_exporter($context)) {
if (ref $exporter) {
push @export_closures, $exporter;
push @export_sources, 'shift(@closures)->($obj, $context)';
} else {
push @export_sources, $exporter;
}
}
}
} );
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 $self->{name}...\n".($Tangram::DEBUG_LEVEL > 1 ? "$export_source\n" : "")
if $Tangram::TRACE;
eval $export_source or die;
}
}
sub get_importer {
my ($self, $context) = @_;
return $self->{IMPORTER} ||= do {
my (@import_sources, @import_closures);
$self->for_composing
( sub {
my ($part) = @_;
$context->{class} = $part;
for my $field ($part->get_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) = \@_;"
."(ref(\$row) eq 'ARRAY') and (\@\$row) or Carp::confess('no row!');\n"
."# line 1 'tangram-$self->{table}-to-$self->{name}.pl'\n"
."$copy_closures\n$import_source }" );
print $Tangram::TRACE "Compiling importer for $self->{name}...\n".($Tangram::DEBUG_LEVEL > 1 ? "$import_source\n" : "")."\n"
if $Tangram::TRACE;
# use Data::Dumper; print Dumper \@cols;
eval $import_source or die;
};
}
1;