use vars qw[ $DEBUG $WARN $VERSION ];$VERSION = '1.59';
$DEBUG = 1 unless defined $DEBUG;
my %translate = (
integer => 'numeric',
int => 'numeric',
number => 'numeric',
money => 'money',
varchar => 'varchar',
varchar2 => 'varchar',
timestamp => 'datetime',
text => 'varchar',
real => 'double precision',
comment => 'text',
bit => 'bit',
tinyint => 'smallint',
float => 'double precision',
serial => 'numeric',
boolean => 'varchar',
char => 'char',
long => 'varchar',
);
my %reserved = map { $_, 1 } qw[
ALL ANALYSE ANALYZE AND ANY AS ASC
BETWEEN BINARY BOTH
CASE CAST CHECK COLLATE COLUMN CONSTRAINT CROSS
CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP CURRENT_USER
DEFAULT DEFERRABLE DESC DISTINCT DO
ELSE END EXCEPT
FALSE FOR FOREIGN FREEZE FROM FULL
GROUP HAVING
ILIKE IN INITIALLY INNER INTERSECT INTO IS ISNULL
JOIN LEADING LEFT LIKE LIMIT
NATURAL NEW NOT NOTNULL NULL
OFF OFFSET OLD ON ONLY OR ORDER OUTER OVERLAPS
PRIMARY PUBLIC REFERENCES RIGHT
SELECT SESSION_USER SOME TABLE THEN TO TRAILING TRUE
UNION UNIQUE USER USING VERBOSE WHEN WHERE
];
my $max_id_length = 30;
my %used_identifiers = ();
my %global_names;
my %unreserve;
my %truncated;
sub produce {
my $translator = shift;
$DEBUG = $translator->debug;
$WARN = $translator->show_warnings;
my $no_comments = $translator->no_comments;
my $add_drop_table = $translator->add_drop_table;
my $schema = $translator->schema;
my $output;
$output .= header_comment unless ($no_comments);
for my $table ( $schema->get_tables ) {
my $table_name = $table->name or next;
$table_name = mk_name( $table_name, '', undef, 1 );
my $table_name_ur = unreserve($table_name) || '';
my ( @comments, @field_defs, @index_defs, @constraint_defs );
push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;
push @comments, map { "-- $_" } $table->comments;
my %field_name_scope;
for my $field ( $table->get_fields ) {
my $field_name = mk_name(
$field->name, '', \%field_name_scope, undef,1
);
my $field_name_ur = unreserve( $field_name, $table_name );
my $field_def = qq["$field_name_ur"];
$field_def =~ s/\"//g;
if ( $field_def =~ /identity/ ){
$field_def =~ s/identity/pidentity/;
}
my $data_type = lc $field->data_type;
my $orig_data_type = $data_type;
my %extra = $field->extra;
my $list = $extra{'list'} || [];
my $commalist = join( ', ', map { qq['$_'] } @$list );
my $seq_name;
if ( $data_type eq 'enum' ) {
my $check_name = mk_name(
$table_name.'_'.$field_name, 'chk' ,undef, 1
);
push @constraint_defs,
"CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
$data_type .= 'character varying';
}
elsif ( $data_type eq 'set' ) {
$data_type .= 'character varying';
}
elsif ( $field->is_auto_increment ) {
$field_def .= ' IDENTITY';
}
else {
if ( defined $translate{ $data_type } ) {
$data_type = $translate{ $data_type };
}
else {
warn "Unknown datatype: $data_type ",
"($table_name.$field_name)\n" if $WARN;
}
}
my $size = $field->size;
unless ( $size ) {
if ( $data_type =~ /numeric/ ) {
$size = '9,0';
}
elsif ( $orig_data_type eq 'text' ) {
$size = '255';
}
elsif (
$data_type eq 'varchar' &&
$orig_data_type eq 'boolean'
) {
$size = '6';
}
elsif ( $data_type eq 'varchar' ) {
$size = '255';
}
}
$field_def .= " $data_type";
$field_def .= "($size)" if $size;
my $default = $field->default_value;
if ( defined $default ) {
$field_def .= sprintf( ' DEFAULT %s',
( $field->is_auto_increment && $seq_name )
? qq[nextval('"$seq_name"'::text)] :
( $default =~ m/null/i ) ? 'NULL' : "'$default'"
);
}
unless ( $field->is_nullable ) {
$field_def .= ' NOT NULL';
}
else {
$field_def .= ' NULL' if $data_type ne 'bit';
}
push @field_defs, $field_def;
}
my @constraint_decs = ();
my $c_name_default;
for my $constraint ( $table->get_constraints ) {
my $name = $constraint->name || '';
my $type = $constraint->type || NORMAL;
my @fields = map { unreserve( $_, $table_name ) }
$constraint->fields;
my @rfields = map { unreserve( $_, $table_name ) }
$constraint->reference_fields;
next unless @fields;
if ( $type eq PRIMARY_KEY ) {
$name ||= mk_name( $table_name, 'pk', undef,1 );
push @constraint_defs,
"CONSTRAINT $name PRIMARY KEY ".
'(' . join( ', ', @fields ) . ')';
}
elsif ( $type eq FOREIGN_KEY ) {
$name ||= mk_name( $table_name, 'fk', undef,1 );
push @constraint_defs,
"CONSTRAINT $name FOREIGN KEY".
' (' . join( ', ', @fields ) . ') REFERENCES '.
$constraint->reference_table.
' (' . join( ', ', @rfields ) . ')';
}
elsif ( $type eq UNIQUE ) {
$name ||= mk_name(
$table_name,
$name || ++$c_name_default,undef, 1
);
push @constraint_defs,
"CONSTRAINT $name UNIQUE " .
'(' . join( ', ', @fields ) . ')';
}
}
for my $index ( $table->get_indices ) {
push @index_defs,
'CREATE INDEX ' . $index->name .
" ON $table_name (".
join( ', ', $index->fields ) . ");";
}
my $create_statement;
$create_statement = qq[DROP TABLE $table_name_ur;\n]
if $add_drop_table;
$create_statement .= qq[CREATE TABLE $table_name_ur (\n].
join( ",\n",
map { " $_" } @field_defs, @constraint_defs
).
"\n);"
;
$output .= join( "\n\n",
@comments,
$create_statement,
@index_defs,
''
);
}
foreach my $view ( $schema->get_views ) {
my (@comments, $view_name);
$view_name = $view->name();
push @comments, "--\n-- View: $view_name\n--" unless $no_comments;
$output .= join("\n\n",
@comments,
$view->sql(),
);
}
foreach my $procedure ( $schema->get_procedures ) {
my (@comments, $procedure_name);
$procedure_name = $procedure->name();
push @comments,
"--\n-- Procedure: $procedure_name\n--" unless $no_comments;
$output .= join("\n\n",
@comments,
$procedure->sql(),
);
}
if ( $WARN ) {
if ( %truncated ) {
warn "Truncated " . keys( %truncated ) . " names:\n";
warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
}
if ( %unreserve ) {
warn "Encounted " . keys( %unreserve ) .
" unsafe names in schema (reserved or invalid):\n";
warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
}
}
return $output;
}
sub mk_name {
my $basename = shift || '';
my $type = shift || '';
my $scope = shift || '';
my $critical = shift || '';
my $basename_orig = $basename;
my $max_name = $type
? $max_id_length - (length($type) + 1)
: $max_id_length;
$basename = substr( $basename, 0, $max_name )
if length( $basename ) > $max_name;
my $name = $type ? "${type}_$basename" : $basename;
if ( $basename ne $basename_orig and $critical ) {
my $show_type = $type ? "+'$type'" : "";
warn "Truncating '$basename_orig'$show_type to $max_id_length ",
"character limit to make '$name'\n" if $WARN;
$truncated{ $basename_orig } = $name;
}
$scope ||= \%global_names;
if ( my $prev = $scope->{ $name } ) {
my $name_orig = $name;
$name .= sprintf( "%02d", ++$prev );
substr($name, $max_id_length - 3) = "00"
if length( $name ) > $max_id_length;
warn "The name '$name_orig' has been changed to ",
"'$name' to make it unique.\n" if $WARN;
$scope->{ $name_orig }++;
}
$name = substr( $name, 0, $max_id_length )
if ((length( $name ) > $max_id_length) && $critical);
$scope->{ $name }++;
return $name;
}
sub unreserve {
my $name = shift || '';
my $schema_obj_name = shift || '';
my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
if ( $schema_obj_name ) {
++$unreserve{"$schema_obj_name.$name"};
}
else {
++$unreserve{"$name (table name)"};
}
my $unreserve = sprintf '%s_', $name;
return $unreserve.$suffix;
}
1;