#!/eit/perl5.005/bin/perl
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'
}},
values
%{
$c
->{
'list_attributes'
}},
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"
;
}
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'
}) {
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"
;
}
}