#!/eit/perl5.005/bin/perl
use strict;
#use Fcntl;
use Carp;
#use vars qw/$OUT_EXT @IN @OUT/;
#$OUT_EXT = 'schema';
#require 'poxargs.pl';
my $p = new POP::POX_parser;
my $lc_name;
my @pox;
my %references;
my %classes;
for my $dir (@ARGV) {
unless (opendir(DIR, $dir)) {
croak "Couldn't open directory [$dir]: $!";
}
for (readdir DIR) {
next unless /\.pox$/;
print STDERR "Reading $_\n";
my $c;
eval {
$c = $p->parse("$dir/$_");
};
if ($@) {
print STDERR $@;
next;
}
next if $c->{'abstract'};
$classes{$c->{'name'}} = $c;
}
closedir DIR;
}
print STDERR "Generating reference counting code\n";
&gen_refs();
print "--MISC CLASS=[INIT]\nsp_addtype pid_type, int\n\n",
"--MISC CLASS=[INIT]\nsp_addtype seq_type, smallint\n\n",
"--MISC CLASS=[INIT]\nsp_addtype ver_type, smallint\n\n";
print "--TABLE CLASS=[INIT]\n",
"create table OBJECTS\n",
" (pid pid_type not null primary key,\n",
" ver int default 0)\n\n";
print "--PROC CLASS=[INIT]\n",
"create proc OBJECTS#VER\n",
" \@pid pid_type\n",
"as\n",
" select ver\n",
" from OBJECTS where pid = \@pid\n\n";
print "--PROC CLASS=[INIT]\n",
"create proc OBJECTS#UPD\n",
" \@pid pid_type\n",
"as\n",
" update OBJECTS set ver = ver + 1 where pid = \@pid\n",
" select ver from OBJECTS where pid = \@pid\n\n";
print "--PROC CLASS=[INIT]\n",
"create proc OBJECTS#NEW\n",
" \@pid pid_type\n",
"as\n",
" insert into OBJECTS (pid, ver) values (\@pid, 1)\n\n";
while (my($class, $c) = each %classes) {
print STDERR "Converting $class\n";
$lc_name = $c->{'dbname'};
print "--TABLE CLASS=[$class]\n",
"create table $lc_name\n",
" (pid pid_type not null primary key,\n",
join(",\n", map {" ".&conv_scalar_att($_)}
values %{$c->{'participants'}},
values %{$c->{'scalar_attributes'}}, # This order
values %{$c->{'list_attributes'}}, # is important!
values %{$c->{'hash_attributes'}}),
")\n\n",
join("\n\n", map {&conv_list_att($class,$_)}
values %{$c->{'list_attributes'}}),
join("\n\n", map {&conv_hash_att($class,$_)}
values %{$c->{'hash_attributes'}}),
"\n\n";
print $references{$c->{'name'}};
for (values %{$c->{'participants'}}) {
print "--INDEX CLASS=[$class]\n",
"create index i_$_->{'dbname'} on $lc_name ($_->{'dbname'})\n\n";
}
print "--PROC CLASS=[$class]\n",
"create proc ${lc_name}#DEL\n",
" \@pid pid_type\n",
"as\n",
" declare \@count int\n",
" exec ${lc_name}#CNT \@pid, \@count output\n",
" if \@count > 0\n",
" return 1\n",
" else\n",
" begin\n",
" delete from OBJECTS where pid = \@pid\n",
" delete from ${lc_name} where pid = \@pid\n",
join('',
map {
" delete from ${lc_name}\@$_->{'dbname'}\n".
" where ${lc_name}_pid = \@pid\n"
} values %{$c->{'list_attributes'}},
values %{$c->{'hash_attributes'}}).
" end\n\n";
if (keys %{$c->{'attributes'}}) {
print "--PROC CLASS=[$class]\n",
"create proc ${lc_name}#GET\n",
" \@pid pid_type\n",
"as\n",
" select ",
join(', ', map {$_->{'dbname'}}
values %{$c->{'participants'}},
values %{$c->{'scalar_attributes'}},
values %{$c->{'list_attributes'}},
values %{$c->{'hash_attributes'}}),"\n",
" from $lc_name\n",
" where pid = \@pid\n\n";
}
foreach (values %{$c->{'list_attributes'}}) {
my $lc_att_name = $_->{'dbname'};
print "--PROC CLASS=[$class]\n",
"create proc ${lc_name}#GET\@$lc_att_name\n",
" \@pid pid_type\n",
"as\n",
" select $lc_att_name\n",
" from ${lc_name}\@$lc_att_name\n",
" where ${lc_name}_pid = \@pid\n",
" order by seq\n\n";
}
foreach (values %{$c->{'hash_attributes'}}) {
my $lc_att_name = $_->{'dbname'};
print "--PROC CLASS=[$class]\n",
"create proc ${lc_name}#GET\@$lc_att_name\n",
" \@pid pid_type\n",
"as\n",
" select hkey, value\n",
" from ${lc_name}\@$lc_att_name\n",
" where ${lc_name}_pid = \@pid\n\n";
}
# This is used to store all the scalar attributes at once, for performance
print "--PROC CLASS=[$class]\n",
"create proc ${lc_name}#SET\n",
join(",\n",
(map {' @'.lc($_->{'name'})." ".&sp_type($_->{'type'})}
{'name'=>'pid', 'type'=>'pid_type'},
values %{$c->{'participants'}},
values %{$c->{'scalar_attributes'}}),
map {' @'.lc($_).'#ver ver_type'}
keys %{$c->{'list_attributes'}},
keys %{$c->{'hash_attributes'}}),"\n",
"as\n",
" delete from $lc_name where pid=\@pid\n",
" insert into ${lc_name}\n",
" (",
join(', ', 'pid',
(map {$_->{'dbname'}}
values %{$c->{'participants'}},
values %{$c->{'scalar_attributes'}},
values %{$c->{'list_attributes'}},
values %{$c->{'hash_attributes'}})
),
")\n",
" values (",
join(', ', '@pid',
(map {'@'.lc($_)} keys %{$c->{'participants'}}, keys %{$c->{'scalar_attributes'}}),
(map {'@'.lc($_).'#ver'} keys %{$c->{'list_attributes'}},
keys %{$c->{'hash_attributes'}})
),
")\n\n";
foreach (values %{$c->{'participants'}}, values %{$c->{'scalar_attributes'}}) {
my $lc_att_name = $_->{'dbname'};
print "--PROC CLASS=[$class]\n",
"create proc ${lc_name}#SET\$$lc_att_name\n",
" \@pid pid_type,\n",
" \@value ",&sp_type($_->{'type'}),"\n",
"as\n",
" update $lc_name\n",
" set $lc_att_name = \@value\n",
" where pid = \@pid\n\n";
}
foreach (values %{$c->{'list_attributes'}},
values %{$c->{'hash_attributes'}}) {
my $lc_att_name = $_->{'dbname'};
if ($_->{'key_type'}) { # hash
print "--PROC CLASS=[$class]\n",
"create proc ${lc_name}#DEL\@$lc_att_name\n",
" \@pid pid_type,\n",
" \@hkey ",&sp_type($_->{'key_type'})," = null\n",
"as\n",
" if (\@hkey is null)\n",
" delete from ${lc_name}\@$lc_att_name\n",
" where ${lc_name}_pid = \@pid\n",
" else\n",
" delete from ${lc_name}\@$lc_att_name\n",
" where ${lc_name}_pid = \@pid and\n",
" hkey = \@hkey\n\n";
print "--PROC CLASS=[$class]\n",
"create proc ${lc_name}#SET\@$lc_att_name\n",
" \@pid pid_type,\n",
" \@key ",&sp_type($_->{'key_type'}),",\n",
" \@value ",&sp_type($_->{'val_type'}),"\n",
"as\n",
" insert into ${lc_name}\@$lc_att_name\n",
" (${lc_name}_pid, hkey, value)\n",
" values (\@pid, \@key, \@value)\n\n";
} else {
print "--PROC CLASS=[$class]\n",
"create proc ${lc_name}#DEL\@$lc_att_name\n",
" \@pid pid_type,\n",
" \@seq seq_type = null\n",
"as\n",
" if (\@seq is null)\n",
" delete from ${lc_name}\@$lc_att_name\n",
" where ${lc_name}_pid = \@pid\n",
" else\n",
" delete from ${lc_name}\@$lc_att_name\n",
" where ${lc_name}_pid = \@pid and\n",
" seq = \@seq\n\n";
print "--PROC CLASS=[$class]\n",
"create proc ${lc_name}#SET\@$lc_att_name\n",
" \@pid pid_type,\n",
" \@value ",&sp_type($_->{'type'}),",\n",
" \@seq seq_type\n",
"as\n",
" insert into ${lc_name}\@$lc_att_name\n",
" (${lc_name}_pid, $lc_att_name, seq)\n",
" values (\@pid, \@value, \@seq)\n\n";
}
print "--PROC CLASS=[$class]\n",
"create proc ${lc_name}#VER\@$lc_att_name\n",
" \@pid pid_type\n",
"as\n",
" declare \@ver ver_type\n",
" select \@ver=$lc_att_name from $lc_name\n",
" if \@ver = 9999\n",
" select \@ver = 0\n",
" else\n",
" select \@ver = \@ver + 1\n",
" update ${lc_name} set $lc_att_name=\@ver\n",
" select \@ver\n\n";
}
}
sub sp_type {
my $type = shift;
if ($type =~ /::/) {
return "pid_type";
} else {
return $type;
}
}
sub conv_scalar_att {
my $att = shift;
my $lc_att_name = $att->{'dbname'};
if ($att->{'list'} || $att->{'hash'}) {
return "$lc_att_name ver_type";
} elsif ($att->{'type'} =~ /::/) {
return "$lc_att_name pid_type";
} elsif ($att->{'type'} eq 'bit') {
return "$lc_att_name $att->{'type'}";
} else {
return "$lc_att_name $att->{'type'} null";
}
}
sub conv_list_att {
my($class, $att) = @_;
return unless $att->{'list'};
my $is_object;
if ($att->{'type'} =~ /::(.*)/) {
$is_object = $1;
}
my $lc_att_name = $att->{'dbname'};
return "--TABLE CLASS=[$class]\n".
"create table ${lc_name}\@$lc_att_name\n".
" (${lc_name}_pid pid_type not null,\n".
" seq seq_type,\n".
($is_object ?
" $lc_att_name pid_type)" :
" $lc_att_name $att->{'type'})")."\n\n".
"--INDEX CLASS=[$class]\n".
"create clustered index i_$lc_att_name\n".
"on ${lc_name}\@$lc_att_name (${lc_name}_pid)\n\n";
}
sub conv_hash_att {
my($class, $att) = @_;
return unless $att->{'hash'};
my $is_object;
if ($att->{'type'} =~ /::(.*)/) {
$is_object = $1;
}
my $lc_att_name = $att->{'dbname'};
return "--TABLE CLASS=[$class]\n".
"create table $lc_name\@$lc_att_name\n".
" (${lc_name}_pid pid_type not null,\n".
" hkey $att->{'key_type'},\n".
($is_object ?
" value pid_type)" :
" value $att->{'val_type'})")."\n\n".
"--INDEX CLASS=[$class]\n".
"create clustered index i_$lc_att_name\n".
"on ${lc_name}\@$lc_att_name (${lc_name}_pid, hkey)\n\n";
}
sub gen_refs {
my %xref;
my %missing;
for my $c (values %classes) {
foreach (values %{$c->{'scalar_attributes'}}) {
if ($_->{'type'} =~ /::/) {
push (@{$xref{$_->{'type'}}}, {
'table' => $c->{'dbname'},
'column' => $_->{'dbname'} });
}
}
foreach (values %{$c->{'list_attributes'}}) {
if ($_->{'type'} =~ /::/) {
push (@{$xref{$_->{'type'}}}, {
'table' => "$c->{'dbname'}\@$_->{'dbname'}",
'column' => "$_->{'dbname'}" });
}
}
foreach (values %{$c->{'hash_attributes'}}) {
if ($_->{'val_type'} =~ /::/) {
push (@{$xref{$_->{'val_type'}}}, {
'table' => "$c->{'dbname'}\@$_->{'dbname'}",
'column' => 'value' });
}
}
$missing{$c->{'name'}} = 1;
}
while (my($class,$refs) = each %xref) {
$class =~ /^$POP_SYSTEM\::(.*)/ or croak "[$class] not in $POP_SYSTEM";
my $c = $classes{$1};
delete $missing{$1};
croak "POX for [$1] not specified.\n" unless $c;
$references{$c->{'name'}} =
"--PROC CLASS=[$c->{'name'}]\n".
"create proc $c->{'dbname'}#CNT\n".
" \@pid pid_type,\n".
" \@count int output\n".
"as\n".
" declare \@cnt int\n".
" select \@count = 0\n".
join("", map {
" select \@cnt = count(*) from $_->{'table'} where $_->{'column'} = \@pid\n".
" select \@count = \@count + \@cnt\n"
} @$refs).
" select \@count\n\n";
}
for my $class (keys %missing) {
my $c = $classes{$class};
$references{$c->{'name'}} =
"--PROC CLASS=[$c->{'name'}]\n".
"create proc $c->{'dbname'}#CNT\n".
" \@pid pid_type,\n".
" \@count int output\n".
"as\n".
" select \@count = 0\n\n";
}
}