I'm working in a multi DB environment, and ddd statements prove to be as
unportable as hell, to say the least :)
My scripts however should be able to deal with whatever database (supported by
us) is thrown at it. At current time it is Unify and Oracle.
I'm attaching the beginnings of a module I've baptized DBD_create.pm which
should eventually catch all these differences for our databases, so I can use
my $expcnt = int (1.7 * scalar keys %ll_adr);
$dbh->create_table (qq;
create table ll_adr (
c_ll numeric (9),
d_in numeric (8),
d_end numeric (8),
type char (1),
c_straat numeric (6),
hnr numeric (5),
hnr_l char (1),
hnr_t string (4),
hnr_a string (2),
pc string (7),
c_plaats numeric (4),
);, count => $expcnt);
$dbh->create_link ("ll_adr.c_ll" => "leerling.c_ll");
$dbh->create_link ("ll_adr.c_straat" => "straat.c_straat");
$dbh->create_link ("ll_adr.c_plaats" => "plaats.c_plaats");
I'm still working on indices, and checking of the link fields: create_link
should croak if any of the tables or fields does not exist.
--8<--- DBD_create.pm
package DBI::db;
use base "DBI";
my ($char, $number, $amnt, $conf) = $ENV{DBTYPE} eq "ORACLE" ?
("varchar2", "number", "number (9, 2)",
[ "", " tablespace PROLEP storage ()" ]) :
("char", "numeric", "amount (8) configuration (display (10, 2))",
[ "configuration (estimated count is $expcnt),\n\t", "" ]);
sub _roundup ($)
{
my $ref = shift;
$$ref <= 50 and return 50;
my $x = 64;
$x <<= 1 while $$ref > $x;
$$ref = $x;
} # _roundup
sub DBI::db::create_table ($$;@)
{
my ($dbh, $ddd, %options) = @_;
my ($bytes, $table, @cnf, $pk) = (0);
# be leanient against a comma after the last field
$ddd =~ s/,([\s\n]*\))/$1/g;
unless (exists $options{segment} or
exists $options{count} && $options{count} > 120) {
$options{count} //= 120;
$options{count} < 120 and $options{count} = 120;
}
$ddd =~ s/\b string \b\s* \(/char \(/gx;
if ($ENV{DBTYPE} eq "ORACLE") {
my $ts = (split m:/:, $ENV{DBUSER}||$ENV{ORACLE_USERID})[0];
$ddd =~ s/ \b numeric \b \s* \(/number (/gx;
$ddd =~ s/ \b char \b \s* \(/varchar2 (/gx;
# Detecting amounts:
# - amount (7) configuration (display (9, 2))
# - huge amount configuration (display (18, 2))
$ddd =~ s/ \b amount \s* \(\s* (\d+) \s*\)
(?: [\s\n]* configuration \s*\(
[\s\n]* [^)]*? display \s* \( (\d+) \s*,\s* (\d+) \s*\) [^)]*
\)
\s*
)? /number ($1-$2-$3)/gx;
$ddd =~ s/ \b huge amount \s*
(?: configuration \s*\(
[\s\n]* [^)]*? display \s* \( (\d+) \s*,\s* (\d+) \s*\) [^)]*
\)
[\s\n]*
)? /number (1-$1-$2)/gx;
$ddd =~ s/(\d+)-(\d+)-(\d+)/sprintf"%d, %d", $2 > $1 ? $2 - 1 : $1, $3/ge;
$bytes += $1 while $ddd =~ m/\(\s*(\d+)/g;
$options{initial} //= 10 * int ($options{count} * $bytes / 10240);
$options{initial} < 50 and $options{initial} = 50;
$options{"next"} //= int ($options{initial} / 4);
$options{"next"} < 50 and $options{"next"} = 50;
@cnf = map { "$_ $options{$_}K" }
grep { exists $options{$_} && _roundup (\$options{$_}) }
qw( initial next );
$options{pctincrease} //= 0;
push @cnf, "pctincrease $options{pctincrease}";
$ddd =~ s/\)\s*;?\s*$/) tablespace $ts storage (@cnf)/;
if ( $ddd =~ s/,[\s\n]*primary\s+(key)\s*\(([^)]+)\)// or
$ddd =~ s/^(\s*(\S+)\b.*)\s+primary key\b/$1/m) {
for (qw( initial next )) {
$options{$_} /= 4;
_roundup (\$options{$_});
}
$pk = join "\n",
"alter table $ts.$table",
" add constraint pk_$table",
" primary key ($2)",
" using index tablespace $ts",
" storage (initial $options{initial}K next $options{'next'}K
pctincrease 0)";
}
}
else {
exists $options{count} and
push @cnf, "estimated count is $options{count}";
exists $options{segment} and
push @cnf, "segment is $options{segment}";
exists $options{description} and
push @cnf, "description '$options{description}'";
if (@cnf) {
my $cnf = join ",\n\t\t", @cnf;
$ddd =~ s/\(/\(\n\tconfiguration ($cnf),/;
}
}
for ($ddd, $pk) {
$_ or next;
$dbh->do ($_);
#print STDERR "$_;\n";
}
} # create table
# $dbh->create_link (qw( ll_adr c_ll leerling c_ll ));
# $dbh->create_link ("bewon", "c_straat", "straat", "c_straat");
# $dbh->create_link ("vb.c_plaats" => "plaats.c_plaats");
# $dbh->create_link ("afn", [ "c_afn", "d_in" ] => "afnemer", [ "afn", "d_afn" ]);
sub DBI::db::create_link ($$$;$$$)
{
my $dbh = shift;
my ($tt, $tf) = $_[0] =~ m/^(\S+)\.(\S+)$/ ? ($1, $2, shift) : (splice @_, 0, 2);
my ($rt, $rf) = $_[0] =~ m/^(\S+)\.(\S+)$/ ? ($1, $2, shift) : (splice @_, 0, 2);
ref $rf or $rf = [ $rf ];
ref $tf or $tf = [ $tf ];
my $ln = shift || "${tt}_$tf->[0]_${rt}";
local $" = ", ";
if ($ENV{DBTYPE} eq "ORACLE") {
my $ts = (split m:/:, $ENV{DBUSER}||$ENV{ORACLE_USERID})[0];
$ln = qq;
alter table $ts.$tt add constraint $ln foreign key
(@$tf) references $ts.$rt (@$rf);
}
else {
$ln = qq;
create link index $ln on $tt (@$tf)
references $rt (@$rf);
}
#print STDERR $ln, "\n";
$dbh->do ($ln);
} # create_link
1-->8---
--
H.Merijn Brand Amsterdam Perl Mongers (http://amsterdam.pm.org/)
using perl-5.6.1, 5.8.0 & 632 on HP-UX 10.20 & 11.00, AIX 4.2, AIX 4.3,
WinNT 4, Win2K pro & WinCE 2.11 often with Tk800.024 &/| DBD-Unify
ftp://ftp.funet.fi/pub/languages/perl/CPAN/authors/id/H/HM/HMBRAND/
