#!/usr/bin/perl -w
# -------------------------------------------------------------------
-# $Id: sql_translator.pl,v 1.5 2002-11-22 03:03:40 kycl4rk Exp $
+# $Id: sql_translator.pl,v 1.6 2002-11-26 03:59:57 kycl4rk Exp $
# -------------------------------------------------------------------
# Copyright (C) 2002 Ken Y. Clark <kycl4rk@users.sourceforge.net>,
# darren chamberlain <darren@cpan.org>
use Data::Dumper;
use vars qw( $VERSION );
-$VERSION = sprintf "%d.%02d", q$Revision: 1.5 $ =~ /(\d+)\.(\d+)/;
-
-my $from; # the original database
-my $to; # the destination database
-my $help; # show POD and bail
-my $stdin; # whether to read STDIN for create script
-my $no_comments; # whether to put comments in out file
-my $xlate; # user overrides for field translation
-my $debug; # whether to print debug info
-my $trace; # whether to print parser trace
-my $list; # list all parsers and producers
+$VERSION = sprintf "%d.%02d", q$Revision: 1.6 $ =~ /(\d+)\.(\d+)/;
+
+my $from; # the original database
+my $to; # the destination database
+my $help; # show POD and bail
+my $stdin; # whether to read STDIN for create script
+my $no_comments; # whether to put comments in out file
+my $show_warnings; # whether to show warnings from SQL::Translator
+my $add_drop_table; # whether to show warnings from SQL::Translator
+my $xlate; # user overrides for field translation
+my $debug; # whether to print debug info
+my $trace; # whether to print parser trace
+my $list; # list all parsers and producers
#
# Get options, explain how to use the script if necessary.
'd|debug' => \$debug,
'trace' => \$trace,
'no-comments' => \$no_comments,
+ 'show-warnings' => \$show_warnings,
+ 'add-drop-table' => \$add_drop_table,
'xlate=s' => \$xlate,
) or pod2usage(2);
#
# If everything is OK, translate file(s).
#
-my $translator = SQL::Translator->new(
- xlate => $xlate || {},
- debug => $debug,
- trace => $trace,
- no_comments => $no_comments,
+my $translator = SQL::Translator->new(
+ xlate => $xlate || {},
+ debug => $debug || 0,
+ trace => $trace || 0,
+ no_comments => $no_comments || 0,
+ show_warnings => $show_warnings || 0,
+ add_drop_table => $add_drop_table || 0,
);
if ( $list ) {
-d|--debug Print debug info
--trace Print parser trace info
--no-comments Don't include comments in SQL output
+ --show-warnings Print to STDERR warnings of conflicts, etc.
+ --add-drop-table Add 'drop table' statements before creates
--xlate=foo/bar,baz/blech Overrides for field translation
=head1 DESCRIPTION
database syntax for which it has a grammar into some other format it
knows about.
+If using "show-warnings," be sure to redirect STDERR to a separate file.
+In bash, you could do this:
+
+ $ sql_translator.pl -f MySQL -t PostgreSQL --show-warnings file.sql \
+ 1>out 2>err
+
=head1 AUTHOR
Ken Y. Clark E<lt>kclark@cpan.orgE<gt>
package SQL::Translator;
# ----------------------------------------------------------------------
-# $Id: Translator.pm,v 1.13 2002-11-25 14:48:34 dlc Exp $
+# $Id: Translator.pm,v 1.14 2002-11-26 03:59:57 kycl4rk Exp $
# ----------------------------------------------------------------------
# Copyright (C) 2002 Ken Y. Clark <kclark@cpan.org>,
# darren chamberlain <darren@cpan.org>
use SQL::Translator;
- my $translator = SQL::Translator->new(
- xlate => $xlate || {}, # Overrides for field translation
- debug => $debug, # Print debug info
- trace => $trace, # Print Parse::RecDescent trace
- no_comments => $no_comments, # Don't include comments in output
+ my $translator = SQL::Translator->new(
+ xlate => $xlate || {}, # Overrides for field translation
+ debug => $debug, # Print debug info
+ trace => $trace, # Print Parse::RecDescent trace
+ no_comments => $no_comments, # Don't include comments in output
+ show_warnings => $show_warnings, # Print name mutations, conflicts
+ add_drop_table => $add_drop_table, # Add "drop table" statements
);
my $output = $translator->translate(
use base 'Class::Base';
$VERSION = '0.01';
-$REVISION = sprintf "%d.%02d", q$Revision: 1.13 $ =~ /(\d+)\.(\d+)/;
+$REVISION = sprintf "%d.%02d", q$Revision: 1.14 $ =~ /(\d+)\.(\d+)/;
$DEBUG = 0 unless defined $DEBUG;
$ERROR = "";
#
$self->{'debug'} = defined $config->{'debug'} ? $config->{'debug'} : $DEBUG;
- $self->trace( $config->{'trace'} );
+
+ $self->add_drop_table( $config->{'add_drop_table'} );
$self->custom_translate( $config->{'xlate'} );
$self->no_comments( $config->{'no_comments'} );
+ $self->show_warnings( $config->{'show_warnings'} );
+
+ $self->trace( $config->{'trace'} );
+
return $self;
}
=head1 METHODS
# ----------------------------------------------------------------------
+=head2 B<add_drop_table>
+
+Toggles whether or not to add "DROP TABLE" statements just before the
+create definitions.
+
+=cut
+
+sub add_drop_table {
+ my $self = shift;
+ if ( defined (my $arg = shift) ) {
+ $self->{'add_drop_table'} = $arg ? 1 : 0;
+ }
+ return $self->{'add_drop_table'} || 0;
+}
+
+
+# ----------------------------------------------------------------------
=head2 B<custom_translate>
Allows the user to override default translation of fields. For example,
}
# ----------------------------------------------------------------------
+=head2 B<show_warnings>
+
+Toggles whether to print warnings of name conflicts, identifier
+mutations, etc. Probably only generated by producers to let the user
+know when something won't translate very smoothly (e.g., MySQL "enum"
+fields into Oracle). Accepts a true or false value, returns the
+current value.
+
+=cut
+
+sub show_warnings {
+ my $self = shift;
+ my $arg = shift;
+ if ( defined $arg ) {
+ $self->{'show_warnings'} = $arg ? 1 : 0;
+ }
+ return $self->{'show_warnings'} || 0;
+}
+
+# ----------------------------------------------------------------------
=head2 B<translate>
The B<translate> method calls the subroutines referenced by the
package SQL::Translator::Producer::Oracle;
# -------------------------------------------------------------------
-# $Id: Oracle.pm,v 1.5 2002-11-23 01:26:56 kycl4rk Exp $
+# $Id: Oracle.pm,v 1.6 2002-11-26 03:59:58 kycl4rk Exp $
# -------------------------------------------------------------------
# Copyright (C) 2002 Ken Y. Clark <kclark@cpan.org>,
# darren chamberlain <darren@cpan.org>
# -------------------------------------------------------------------
use strict;
-use vars qw[ $VERSION $DEBUG ];
-$VERSION = sprintf "%d.%02d", q$Revision: 1.5 $ =~ /(\d+)\.(\d+)/;
+use vars qw[ $VERSION $DEBUG $WARN ];
+$VERSION = sprintf "%d.%02d", q$Revision: 1.6 $ =~ /(\d+)\.(\d+)/;
$DEBUG = 0 unless defined $DEBUG;
-my $max_id_length = 30;
-my %used_identifiers = ();
-
my %translate = (
#
# MySQL types
# http://technet.oracle.com/docs/products/oracle8i/doc_library/\
# 817_doc/server.817/a85397/ap_keywd.htm
#
-my @ora_reserved = qw(
+my %ora_reserved = map { $_, 1 } qw(
ACCESS ADD ALL ALTER AND ANY AS ASC AUDIT
BETWEEN BY
CHAR CHECK CLUSTER COLUMN COMMENT COMPRESS CONNECT CREATE CURRENT
WHENEVER WHERE WITH
);
-my %ora_reserved = map { $_ => 1 } @ora_reserved;
+my $max_id_length = 30;
+my %used_identifiers = ();
my %global_names;
my %unreserve;
my %truncated;
+# -------------------------------------------------------------------
sub produce {
my ( $translator, $data ) = @_;
$DEBUG = $translator->debug;
+ $WARN = $translator->show_warnings;
my $no_comments = $translator->no_comments;
+ my $add_drop_table = $translator->add_drop_table;
my $output;
unless ( $no_comments ) {
if ( uc $field->{'data_type'} eq 'TIMESTAMP' ) {
my $base_name = $table_name . "_". $field_name_ur;
- my $trig_name = mk_name($base_name,'ts');
+ my $trig_name = mk_name( $base_name, 'ts' );
push @trigger_decs,
"CREATE OR REPLACE TRIGGER $trig_name\n".
"BEFORE INSERT OR UPDATE ON $table_name_ur\n".
join( ', ', @fields ). ");";
}
else {
- warn "Unknown index type ($index_type) on table $table_name.\n";
+ warn "Unknown index type ($index_type) on table $table_name.\n"
+ if $WARN;
}
}
- my $create_statement = "CREATE TABLE $table_name_ur (\n".
+ my $create_statement;
+ $create_statement = "DROP TABLE $table_name_ur;\n" if $add_drop_table;
+ $create_statement .= "CREATE TABLE $table_name_ur (\n".
join( ",\n", map { " $_" } @field_decs ).
"\n);"
;
);
}
+ 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;
}
my ($basename, $type, $scope, $critical) = @_;
my $basename_orig = $basename;
my $max_name = $max_id_length - (length($type) + 1);
- $basename = substr($basename, 0, $max_name)
- if length($basename) > $max_name;
+ $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 $DEBUG;
- $truncated{$basename_orig} = $name;
+ "character limit to make '$name'\n" if $WARN;
+ $truncated{ $basename_orig } = $name;
}
$scope ||= \%global_names;
- return $name unless $scope->{$name}++;
- my $name_orig = $name;
- $name .= "02";
- substr($name, $max_id_length - 3) = "00" if length($name) > $max_id_length;
- ++$name while $scope->{$name};
- warn "The name '$name_orig' has been changed to ",
- "'$name' to make it unique\n" if $DEBUG;
+ 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 }++;
+ }
+
+ $scope->{ $name }++;
return $name;
}
# -------------------------------------------------------------------
sub unreserve {
- my ($name, $schema_obj_name) = @_;
- my ($suffix) = ($name =~ s/(\W.*)$//) ? $1 : '';
+ my ( $name, $schema_obj_name ) = @_;
+ my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
# also trap fields that don't begin with a letter
- return $_[0] if !$ora_reserved{uc $name}
- && $name =~ /^[a-z]/i;
+ return $_[0] if !$ora_reserved{ uc $name } && $name =~ /^[a-z]/i;
if ( $schema_obj_name ) {
++$unreserve{"$schema_obj_name.$name"};
created by a SQL::Translator::Parser subclass, and turns it into a
create string suitable for use with an Oracle database.
-=head1 BUGS
-
-Problem with SQL::Translator::Producer::Oracle: it is keeping track
-of the last sequence number used, so as not to duplicate them, which
-is reasonable. However on runs past the first, it seems to be
-creating multiple constraint lines, that look like:
-
- CONSTRAINT i_sessions_pk_2 PRIMARY KEY (id),
- CONSTRAINT i_sessions_pk_3 PRIMARY KEY (id)
-
-This is a very preliminary finding, and needs to be investigated more
-thoroughly, of course.
-
=head1 CREDITS
A hearty "thank-you" to Tim Bunce for much of the logic stolen from
perl(1).
=cut
-
-__END__
-!!!!!Code Graveyard!!!!!
-#
-# Used to make index names
-#
-sub make_identifier {
- my ( $identifier, @mutations ) = @_;
- my $length_of_mutations;
- for my $mutation ( @mutations ) {
- $length_of_mutations += length( $mutation );
- }
-
- if (
- length( $identifier ) + $length_of_mutations >
- $max_id_length
- ) {
- $identifier = substr(
- $identifier,
- 0,
- $max_id_length - $length_of_mutations
- );
- }
-
- for my $mutation ( @mutations ) {
- if ( $mutation =~ m/.+_$/ ) {
- $identifier = $mutation.$identifier;
- }
- elsif ( $mutation =~ m/^_.+/ ) {
- $identifier = $identifier.$mutation;
- }
- }
-
- if ( $used_identifiers{ $identifier } ) {
- my $index = 1;
- if ( $identifier =~ m/_(\d+)$/ ) {
- $index = $1;
- $identifier = substr(
- $identifier,
- 0,
- length( $identifier ) - ( length( $index ) + 1 )
- );
- }
- $index++;
- return make_identifier( $identifier, '_'.$index );
- }
-
- $used_identifiers{ $identifier } = 1;
-
- return $identifier;
-}
-
-#
-# Checks to see if an identifier is not too long
-#
-sub check_identifier {
- my $identifier = shift;
- die "Identifier '$identifier' is too long, unrecoverable error.\n"
- if length( $identifier ) > $max_id_length;
- return $identifier;
-}
-
package SQL::Translator::Producer::PostgreSQL;
# -------------------------------------------------------------------
-# $Id: PostgreSQL.pm,v 1.2 2002-11-22 03:03:40 kycl4rk Exp $
+# $Id: PostgreSQL.pm,v 1.3 2002-11-26 03:59:58 kycl4rk Exp $
# -------------------------------------------------------------------
# Copyright (C) 2002 Ken Y. Clark <kclark@cpan.org>,
# darren chamberlain <darren@cpan.org>
# 02111-1307 USA
# -------------------------------------------------------------------
+=head1 NAME
+
+SQL::Translator::Producer::PostgreSQL - PostgreSQL producer for SQL::Translator
+
+=cut
+
use strict;
-use vars qw($VERSION $DEBUG);
-$VERSION = sprintf "%d.%02d", q$Revision: 1.2 $ =~ /(\d+)\.(\d+)/;
+use vars qw[ $DEBUG $WARN $VERSION ];
+$VERSION = sprintf "%d.%02d", q$Revision: 1.3 $ =~ /(\d+)\.(\d+)/;
$DEBUG = 1 unless defined $DEBUG;
use Data::Dumper;
#
# Oracle types
#
+ number => 'integer',
+ char => 'char',
+ varchar2 => 'varchar',
+ long => 'text',
+ CLOB => 'bytea',
+ date => 'date',
+
+ #
+ # Sybase types
+ #
+ int => 'integer',
+ money => 'money',
+ varchar => 'varchar',
+ datetime => 'timestamp',
+ text => 'text',
+ real => 'double precision',
+ comment => 'text',
+ bit => 'bit',
+ tinyint => 'smallint',
+ float => 'double precision',
);
+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
+];
-sub import {
- warn "loading " . __PACKAGE__ . "...\n";
-}
+my $max_id_length = 30;
+my %used_identifiers = ();
+my %global_names;
+my %unreserve;
+my %truncated;
+
+=pod
+
+=head1 PostgreSQL Create Table Syntax
+
+ CREATE [ [ LOCAL ] { TEMPORARY | TEMP } ] TABLE table_name (
+ { column_name data_type [ DEFAULT default_expr ] [ column_constraint [, ... ] ]
+ | table_constraint } [, ... ]
+ )
+ [ INHERITS ( parent_table [, ... ] ) ]
+ [ WITH OIDS | WITHOUT OIDS ]
+
+where column_constraint is:
+
+ [ CONSTRAINT constraint_name ]
+ { NOT NULL | NULL | UNIQUE | PRIMARY KEY |
+ CHECK (expression) |
+ REFERENCES reftable [ ( refcolumn ) ] [ MATCH FULL | MATCH PARTIAL ]
+ [ ON DELETE action ] [ ON UPDATE action ] }
+ [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
+
+and table_constraint is:
+
+ [ CONSTRAINT constraint_name ]
+ { UNIQUE ( column_name [, ... ] ) |
+ PRIMARY KEY ( column_name [, ... ] ) |
+ CHECK ( expression ) |
+ FOREIGN KEY ( column_name [, ... ] ) REFERENCES reftable [ ( refcolumn [, ... ] ) ]
+ [ MATCH FULL | MATCH PARTIAL ] [ ON DELETE action ] [ ON UPDATE action ] }
+ [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
+
+=cut
+# -------------------------------------------------------------------
sub produce {
my ( $translator, $data ) = @_;
- debug("Beginning production\n");
- my $create = sprintf "--\n-- Created by %s\n-- Created on %s\n-- \n\n",
- __PACKAGE__, scalar localtime;
-
- for my $table ( keys %{ $data } ) {
- debug( "Looking at table '$table'\n" );
- my $table_data = $data->{$table};
- my @fields = sort {
- $table_data->{'fields'}->{$a}->{'order'}
- <=>
- $table_data->{'fields'}->{$b}->{'order'}
- } keys %{ $table_data->{'fields'} };
-
- $create .= "--\n-- Table: $table\n--\n";
- $create .= "CREATE TABLE $table (\n";
+ $DEBUG = $translator->debug;
+ $WARN = $translator->show_warnings;
+ my $no_comments = $translator->no_comments;
+ my $add_drop_table = $translator->add_drop_table;
+
+ my $create;
+ unless ( $no_comments ) {
+ $create .= sprintf
+ "--\n-- Created by %s\n-- Created on %s\n--\n\n",
+ __PACKAGE__, scalar localtime;
+ }
+
+ for my $table (
+ map { $_->[1] }
+ sort { $a->[0] <=> $b->[0] }
+ map { [ $_->{'order'}, $_ ] }
+ values %$data
+ ) {
+ my $table_name = $table->{'table_name'};
+ my @fields =
+ map { $_->[1] }
+ sort { $a->[0] <=> $b->[0] }
+ map { [ $_->{'order'}, $_ ] }
+ values %{ $table->{'fields'} };
+
+ $create .= "--\n-- Table: $table_name\n--\n" unless $no_comments;
+ $create = "DROP TABLE $table_name;\n" if $add_drop_table;
+ $create .= "CREATE TABLE $table_name (\n";
#
# Fields
#
+ my %field_name_scope;
my @field_statements;
for my $field ( @fields ) {
- debug("Looking at field '$field'\n");
- my $field_data = $table_data->{'fields'}->{ $field };
- my @fdata = ("", $field);
+ my @fdata = ("", $field);
+
+ my $field_name = mk_name(
+ $field->{'name'}, '', \%field_name_scope, 1
+ );
+ my $field_name_ur = unreserve( $field_name, $table_name );
+ my $field_str = $field_name_ur;
# data type and size
push @fdata, sprintf "%s%s",
- $field_data->{'data_type'},
- ( defined $field_data->{'size'} )
- ? "($field_data->{'size'})" : '';
+ $field->{'data_type'},
+ ( defined $field->{'size'} )
+ ? "($field->{'size'})" : '';
# Null?
- push @fdata, "NOT NULL" unless $field_data->{'null'};
+ push @fdata, "NOT NULL" unless $field->{'null'};
# Default? XXX Need better quoting!
- my $default = $field_data->{'default'};
+ my $default = $field->{'default'};
if ( defined $default ) {
push @fdata, "DEFAULT '$default'";
# if (int $default eq "$default") {
}
# auto_increment?
- push @fdata, "auto_increment" if $field_data->{'is_auto_inc'};
+ push @fdata, "auto_increment" if $field->{'is_auto_inc'};
# primary key?
- push @fdata, "PRIMARY KEY" if $field_data->{'is_primary_key'};
+ push @fdata, "PRIMARY KEY" if $field->{'is_primary_key'};
push @field_statements, join( " ", @fdata );
#
# Other keys
#
- my @indices = @{ $table_data->{'indices'} || [] };
+ my @indices = @{ $table->{'indices'} || [] };
for ( my $i = 0; $i <= $#indices; $i++ ) {
$create .= ",\n";
my $key = $indices[$i];
return $create;
}
-use Carp;
-sub debug {
- if ( $DEBUG ) {
- map { carp "[" . __PACKAGE__ . "] $_" } @_;
+# -------------------------------------------------------------------
+sub mk_name {
+ my ($basename, $type, $scope, $critical) = @_;
+ my $basename_orig = $basename;
+ my $max_name = $max_id_length - (length($type) + 1);
+ $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 }++;
}
+
+ $scope->{ $name }++;
+ return $name;
+}
+
+# -------------------------------------------------------------------
+sub unreserve {
+ my ( $name, $schema_obj_name ) = @_;
+ my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
+
+ # also trap fields that don't begin with a letter
+ return $_[0] 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;
-__END__
-=head1 NAME
+# -------------------------------------------------------------------
+# Life is full of misery, loneliness, and suffering --
+# and it's all over much too soon.
+# Woody Allen
+# -------------------------------------------------------------------
-SQL::Translator::Producer::PostgreSQL - PostgreSQL-specific producer for SQL::Translator
+=pod
=head1 AUTHOR
projects / dbsrgits/SQL-Translator.git / commitdiff