From: Ken Youens-Clark Date: Fri, 1 Mar 2002 02:26:25 +0000 (+0000) Subject: Initial checkin. X-Git-Tag: v0.01~63 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=16dc997057306c2b93d146478b7b20830d3b5d80;p=dbsrgits%2FSQL-Translator.git Initial checkin. --- 16dc997057306c2b93d146478b7b20830d3b5d80 diff --git a/bin/sql_translator.pl b/bin/sql_translator.pl new file mode 100755 index 0000000..7c2bcf4 --- /dev/null +++ b/bin/sql_translator.pl @@ -0,0 +1,89 @@ +#!/usr/bin/perl -w + +#----------------------------------------------------- +# $Id: sql_translator.pl,v 1.1.1.1 2002-03-01 02:26:25 kycl4rk Exp $ +# +# File : sql_translator.pl +# Programmer : Ken Y. Clark, kclark@logsoft.com +# Created : 2002/02/27 +# Purpose : invoke SQL::Translator +#----------------------------------------------------- + +use strict; +use Getopt::Long; +use Pod::Usage; +use SQL::Translator; +use vars qw( $VERSION ); +$VERSION = (qw$Revision: 1.1.1.1 $)[-1]; + +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 $verbose; # whether to print progress/debug + +# +# Get options, explain how to use the script if necessary. +# +GetOptions( + 'f|from=s' => \$from, + 't|to=s' => \$to, + 'h|help' => \$help, + 'v|verbose' => \$verbose, + 'no_comments' => \$no_comments, +) or pod2usage(2); + +my @files = @ARGV; # the create script for the original db + +pod2usage(1) if $help; +pod2usage(2) unless $from && $to && @files; + +# +# If everything is OK, translate file(s). +# +my $translator = SQL::Translator->new; +my $output = $translator->translate( + from => $from, + to => $to, + input => \@files, + verbose => $verbose, + no_comments => $no_comments, +) or die "Error: " . $translator->error; +print "Output:\n", $output; + +#----------------------------------------------------- +# It is not all books that are as dull as their readers. +# Henry David Thoreau +#----------------------------------------------------- + +=head1 NAME + +sql_translator.pl - convert schema to Oracle syntax + +=head1 SYNOPSIS + + ./sql_translator.pl -h|--help + + ./sql_translator.pl -f|--from mysql -t|--to oracle [options] file + + Options: + + -v|--verbose Print debug info to STDERR + --no-comments Don't include comments in SQL output + +=head1 DESCRIPTION + +Part of the SQL Fairy project (sqlfairy.sourceforge.net), this script +will try to convert any database syntax for which it has a grammar +into some other format will accept. + +=head1 AUTHOR + +Ken Y. Clark, kclark@logsoft.com + +=head1 SEE ALSO + +perl(1), SQL::Transport. + +=cut diff --git a/lib/SQL/Translator.pm b/lib/SQL/Translator.pm new file mode 100644 index 0000000..25b7190 --- /dev/null +++ b/lib/SQL/Translator.pm @@ -0,0 +1,199 @@ +package SQL::Translator; + +#----------------------------------------------------- +# $Id: Translator.pm,v 1.1.1.1 2002-03-01 02:26:25 kycl4rk Exp $ +# +# File : SQL/Translator.pm +# Programmer : Ken Y. Clark, kclark@logsoft.com +# Created : 2002/02/27 +# Purpose : convert schema from one database to another +#----------------------------------------------------- + +use strict; +use vars qw( $VERSION ); +$VERSION = (qw$Revision: 1.1.1.1 $)[-1]; + +use Data::Dumper; + +use SQL::Translator::Parser::MySQL; +use SQL::Translator::Parser::Sybase; +use SQL::Translator::Producer::Oracle; +use SQL::Translator::Producer::XML; + +# +# These are the inputs we can parse. +# +my %parsers = ( + mysql => 'MySQL', + sybase => 'Sybase', +); + +# +# These are the formats we can produce. +# +my %producers = ( + oracle => 'Oracle', + xml => 'XML', +); + +#----------------------------------------------------- +sub new { +# +# Makes a new object. Intentionally made very bare as +# it is used by all subclasses (unless they override, +# of course). +# + my $class = shift; + my %args = @_; + my $self = { %args }; + return bless $self, $class; +} + +#----------------------------------------------------- +sub error { +# +# Return the last error. +# + return shift()->{'error'} || ''; +} + +#----------------------------------------------------- +sub error_out { +# +# Record the error and return undef. +# + my $self = shift; + if ( my $error = shift ) { + $self->{'error'} = $error; + } + return; +} + +#----------------------------------------------------- +sub translate { +# +# Translates any number of given files. +# + my ( $self, %args ) = @_; + my $from = $args{'from'} || ''; + my $to = $args{'to'} || ''; + my $input = $args{'input'} || []; + my $verbose = $args{'verbose'} || 0; + my $no_comments = $args{'no_comments'} || 0; + + if ( exists $parsers{ $from } ) { + $self->{'from'} = $from; + warn "Using parser '$from.'\n" if $verbose; + } + else { + my $msg = "The parsers '$from' is not valid.\n" . + "Please choose from the following list:\n"; + $msg .= " $_\n" for sort keys %parsers; + return $self->error_out( $msg ); + } + + if ( exists $producers{ $to } ) { + $self->{'to'} = $to; + warn "Using producer '$to.'\n" if $verbose; + } + else { + my $msg = "The producer '$to' is not valid.\n" . + "Please choose from the following list:\n"; + $msg .= " $_\n" for sort keys %producers; + return $self->error_out( $msg ); + } + + # + # Slurp the entire text file we're parsing. + # + my $parser = $self->parser; + my $producer = $self->producer; + my $data; + for my $file ( @$input ) { + warn "Parsing file '$file.'\n" if $verbose; + open my $fh, $file or return $self->error_out( "Can't read $file: $!" ); + local $/; + $data = $parser->parse( <$fh> ); + } + + warn "Data =\n", Dumper( $data ) if $verbose; + my $output = $producer->translate( $data ); +} + +#----------------------------------------------------- +sub parser { +# +# Figures out which module to load based on the "from" argument +# + my $self = shift; + unless ( $self->{'parser'} ) { + my $parser_module = + 'SQL::Translator::Parser::'.$parsers{ $self->{'from'} }; + $self->{'parser'} = $parser_module->new; + } + return $self->{'parser'}; +} + +#----------------------------------------------------- +sub producer { +# +# Figures out which module to load based on the "to" argument +# + my $self = shift; + unless ( $self->{'producer'} ) { + my $from = $parsers{ $self->{'from'} }; + my $producer_module = + 'SQL::Translator::Producer::'.$producers{ $self->{'to'} }; + $self->{'producer'} = $producer_module->new( from => $from ); + } + return $self->{'producer'}; +} + +1; + +#----------------------------------------------------- +# Rescue the drowning and tie your shoestrings. +# Henry David Thoreau +#----------------------------------------------------- + +=head1 NAME + +SQL::Translator - convert schema from one database to another + +=head1 SYNOPSIS + + use SQL::Translator; + my $translator = SQL::Translator->new; + my $output = $translator->translate( + from => 'mysql', + to => 'oracle', + file => $file, + ) or die $translator->error; + print $output; + +=head1 DESCRIPTION + +This module attempts to simplify the task of converting one database +create syntax to another through the use of Parsers and Producers. +The idea is that any Parser can be used with any Producer in the +conversion process. So, if you wanted PostgreSQL-to-Oracle, you could +just write the PostgreSQL parser and use an existing Oracle producer. + +Currently, the existing parsers use Parse::RecDescent, and the +producers are just printing formatted output of the parsed data +structure. New parsers don't necessarily have to use +Parse::RecDescent, however, as long as the data structure conforms to +what the producers are expecting. With this separation of code, it is +hoped that developers will find it easy to add more database dialects +by using what's written, writing only what they need, and then +contributing their parsers or producers back to the project. + +=head1 AUTHOR + +Ken Y. Clark, kclark@logsoft.com + +=head1 SEE ALSO + +perl(1). + +=cut diff --git a/lib/SQL/Translator/Parser.pm b/lib/SQL/Translator/Parser.pm new file mode 100644 index 0000000..29e7a2d --- /dev/null +++ b/lib/SQL/Translator/Parser.pm @@ -0,0 +1,66 @@ +package SQL::Translator::Parser; + +#----------------------------------------------------- +# $Id: Parser.pm,v 1.1.1.1 2002-03-01 02:26:25 kycl4rk Exp $ +# +# File : SQL/Translator/Parser.pm +# Programmer : Ken Y. Clark, kclark@logsoft.com +# Created : 2002/02/27 +# Purpose : base object for parsers +#----------------------------------------------------- + +use strict; +use vars qw( $VERSION ); +$VERSION = (qw$Revision: 1.1.1.1 $)[-1]; + +use Parse::RecDescent; +use SQL::Translator; +use base qw[ SQL::Translator ]; + +sub parse { +# +# Override this method if you intend not to use Parse::RecDescent +# + my $self = shift; + return $self->parser->file( shift() ); +} + +sub parser { + my $self = shift; + unless ( $self->{'parser'} ) { + $self->{'parser'} = Parse::RecDescent->new( $self->grammar ); + } + return $self->{'parser'}; +} + +1; + +#----------------------------------------------------- +# Enough! or Too much. +# William Blake +#----------------------------------------------------- + +=head1 NAME + +SQL::Translator::Parser - base object for parsers + +=head1 SYNOPSIS + + package SQL::Translator::Parser::Foo; + use SQL::Translator::Parser; + use base( 'SQL::Translator::Parser' ); + 1; + +=head1 DESCRIPTION + +Blah blah blah. + +=head1 AUTHOR + +Ken Y. Clark, kclark@logsoft.com + +=head1 SEE ALSO + +perl(1). + +=cut diff --git a/lib/SQL/Translator/Parser/MySQL.pm b/lib/SQL/Translator/Parser/MySQL.pm new file mode 100644 index 0000000..26b5445 --- /dev/null +++ b/lib/SQL/Translator/Parser/MySQL.pm @@ -0,0 +1,190 @@ +package SQL::Translator::Parser::MySQL; + +#----------------------------------------------------- +# $Id: MySQL.pm,v 1.1.1.1 2002-03-01 02:26:25 kycl4rk Exp $ +# +# File : SQL::Translator::Parser::MySQL +# Programmer : Ken Y. Clark, kclark@logsoft.com +# Created : 2002/02/27 +# Purpose : parser for MySQL +#----------------------------------------------------- + +use strict; +use vars qw( $VERSION ); +$VERSION = (qw$Revision: 1.1.1.1 $)[-1]; + +use SQL::Translator::Parser; +use base qw[ SQL::Translator::Parser ]; + +sub grammar { + q{ + { our ( %tables ) } + + file : statement(s) { \%tables } + + statement : comment + | create + | + + create : create_table table_name '(' line(s /,/) ')' table_type(?) ';' + { + my $i = 0; + for my $line ( @{ $item[4] } ) { + if ( $line->{'type'} eq 'field' ) { + my $field_name = $line->{'name'}; + $tables{ $item{'table_name'} } + {'fields'}{$field_name} = + { %$line, order => $i }; + $i++; + + if ( $line->{'is_primary_key'} ) { + push + @{ $tables{ $item{'table_name'} }{'indeces'} }, + { + type => 'primary_key', + fields => [ $field_name ], + }; + } + } + else { + push @{ $tables{ $item{'table_name'} }{'indeces'} }, + $line; + } + $tables{ $item{'table_name'} }{'type'} = + $item{'table_type'}[0]; + } + } + | + + line : index + | field + | + + comment : /^\s*#.*\n/ + + blank : /\s*/ + + field : field_name data_type not_null(?) default_val(?) auto_inc(?) primary_key(?) + { + my $null = defined $item{'not_null'}[0] + ? $item{'not_null'}[0] : 1 ; + $return = { + type => 'field', + name => $item{'field_name'}, + data_type => $item{'data_type'}{'type'}, + size => $item{'data_type'}{'size'}, + null => $null, + default => $item{'default_val'}[0], + is_auto_inc => $item{'auto_inc'}[0], + is_primary_key => $item{'primary_key'}[0], + } + } + | + + index : primary_key_index + | unique_index + | normal_index + + table_name : WORD + + field_name : WORD + + index_name : WORD + + data_type : WORD field_size(?) + { + $return = { + type => $item[1], + size => $item[2][0] + } + } + + field_type : WORD + + field_size : '(' num_range ')' { $item{'num_range'} } + + num_range : DIGITS ',' DIGITS + { $return = $item[1].','.$item[3] } + | DIGITS + { $return = $item[1] } + + + create_table : /create/i /table/i + + not_null : /not/i /null/i { $return = 0 } + + default_val : /default/i /(?:')?[\w\d.-]*(?:')?/ { $item[2]=~s/'//g; $return=$item[2] } + + auto_inc : /auto_increment/i { 1 } + + primary_key : /primary/i /key/i { 1 } + + primary_key_index : primary_key index_name(?) '(' field_name(s /,/) ')' + { + $return = { + name => $item{'index_name'}[0], + type => 'primary_key', + fields => $item[4], + } + } + + normal_index : key index_name(?) '(' field_name(s /,/) ')' + { + $return = { + name => $item{'index_name'}[0], + type => 'normal', + fields => $item[4], + } + } + + unique_index : /unique/i key index_name(?) '(' field_name(s /,/) ')' + { + $return = { + name => $item{'index_name'}[0], + type => 'unique', + fields => $item[5], + } + } + + key : /key/i + | /index/i + + table_type : /TYPE=/i /\w+/ { $item[2] } + + WORD : /\w+/ + + DIGITS : /\d+/ + + COMMA : ',' + + }; +} + +1; + +#----------------------------------------------------- +# Where man is not nature is barren. +# William Blake +#----------------------------------------------------- + +=head1 NAME + +SQL::Translator::Parser::MySQL - parser for MySQL + +=head1 SYNOPSIS + + use SQL::Translator::Parser::MySQL; + +=head1 DESCRIPTION + +Blah blah blah. + +=head1 AUTHOR + +Ken Y. Clark, kclark@logsoft.com + +=head1 SEE ALSO + +perl(1). + +=cut diff --git a/lib/SQL/Translator/Parser/Sybase.pm b/lib/SQL/Translator/Parser/Sybase.pm new file mode 100644 index 0000000..6ab1468 --- /dev/null +++ b/lib/SQL/Translator/Parser/Sybase.pm @@ -0,0 +1,235 @@ +package SQL::Translator::Parser::Sybase; + +#----------------------------------------------------- +# $Id: Sybase.pm,v 1.1.1.1 2002-03-01 02:26:25 kycl4rk Exp $ +# +# File : SQL/Translator/Parser/Sybase.pm +# Programmer : Ken Y. Clark, kclark@logsoft.com +# Created : 2002/02/27 +# Purpose : parser for Sybase (dbschema.pl) +#----------------------------------------------------- + +my $grammar = q{ + + { our ( %tables ) } + + file : statement(s) { \%tables } +# { print "statements: ", join("\n", @{$item[1]}), "\n" } +# | + + statement : create + | junk +# { +# print "statement: ", join("\n", @{$item[1]}), "\n"; +# $return = @{$item[1]}; +# print "statement: '", $item[1], "'\n"; +# $return = $item[1]; +# } + | + + junk : comment + | use + | setuser + | if + | print + | else + | begin + | end + | grant + | exec + | GO + + GO : /go/ +# { print "GO: ", $item[1], "\n" } + + use : /use/i /.*/ +# { print "USE: ", $item[2], "\n" } + + setuser : /setuser/i /.*/ +# { print "SETUSER: ", $item[2], "\n" } + + if : /if/i /.*/ +# { print "IF: ", $item[2], "\n" } + + print : /\s*/ /print/i /.*/ +# { print "PRINT: ", $item[3], "\n" } + + else : /else/i /.*/ +# { print "ELSE: ", $item[2], "\n" } + + begin : /begin/i +# { print "BEGIN\n" } + + end : /end/i +# { print "END\n" } + + grant : /grant/i /.*/ +# { print "GRANT: ", $item[2], "\n" } + + exec : /exec/i /.*/ +# { print "EXEC: ", $item[2], "\n" } + + comment : /^\s*\/\*.*\*\//m +# { print "COMMENT: ", $item[-1], "\n" } + + create : create_table table_name '(' field(s /,/) ')' lock(?) + { +# print "TABLE $item[2]: ", +# join(', ', map{$_->{'name'}}@{$item[4]}), "\n"; + my $i = 0; + for my $line ( @{ $item[4] } ) { + if ( $line->{'type'} eq 'field' ) { + my $field_name = $line->{'name'}; + $tables{ $item{'table_name'} } + {'fields'}{$field_name} = + { %$line, order => $i }; + $i++; + + if ( $line->{'is_primary_key'} ) { + push + @{ $tables{ $item{'table_name'} }{'indeces'} }, + { + type => 'primary_key', + fields => [ $field_name ], + }; + } + } + else { + push @{ $tables{ $item{'table_name'} }{'indeces'} }, + $line; + } + $tables{ $item{'table_name'} }{'type'} = + $item{'table_type'}[0]; + } + } + | + + blank : /\s*/ + + field : field_name data_type null(?) + { + $return = { + type => 'field', + name => $item{'field_name'}, + data_type => $item{'data_type'}{'type'}, + size => $item{'data_type'}{'size'}, + null => $item{'null'}[0], +# default => $item{'default_val'}[0], +# is_auto_inc => $item{'auto_inc'}[0], +# is_primary_key => $item{'primary_key'}[0], + } + } + | + + index : primary_key_index + | unique_index + | normal_index + + table_name : WORD '.' WORD + { $return = $item[3] } + + field_name : WORD + + index_name : WORD + + data_type : WORD field_size(?) + { + $return = { + type => $item[1], + size => $item[2][0] + } + } + + lock : /lock/i /datarows/i + + field_type : WORD + + field_size : '(' num_range ')' { $item{'num_range'} } + + num_range : DIGITS ',' DIGITS + { $return = $item[1].','.$item[3] } + | DIGITS + { $return = $item[1] } + + + create_table : /create/i /table/i + + null : /not/i /null/i + { $return = 0 } + | /null/i + { $return = 1 } + + default_val : /default/i /(?:')?[\w\d.-]*(?:')?/ { $item[2]=~s/'//g; $return=$item[2] } + + auto_inc : /auto_increment/i { 1 } + + primary_key : /primary/i /key/i { 1 } + + primary_key_index : primary_key index_name(?) '(' field_name(s /,/) ')' + { + $return = { + name => $item{'index_name'}[0], + type => 'primary_key', + fields => $item[4], + } + } + + normal_index : key index_name(?) '(' field_name(s /,/) ')' + { + $return = { + name => $item{'index_name'}[0], + type => 'normal', + fields => $item[4], + } + } + + unique_index : /unique/i key index_name(?) '(' field_name(s /,/) ')' + { + $return = { + name => $item{'index_name'}[0], + type => 'unique', + fields => $item[5], + } + } + + key : /key/i + | /index/i + + table_type : /TYPE=/i /\w+/ { $item[2] } + + WORD : /[\w#]+/ + + DIGITS : /\d+/ + + COMMA : ',' + +}; + +1; + +#----------------------------------------------------- +# Every hero becomes a bore at last. +# Ralph Waldo Emerson +#----------------------------------------------------- + +=head1 NAME + +SQL::Translator::Parser::Sybase - parser for Sybase + +=head1 SYNOPSIS + + use SQL::Translator::Parser::Sybase; + +=head1 DESCRIPTION + +Blah blah blah. + +=head1 AUTHOR + +Ken Y. Clark, kclark@logsoft.com + +=head1 SEE ALSO + +perl(1). + +=cut diff --git a/lib/SQL/Translator/Producer.pm b/lib/SQL/Translator/Producer.pm new file mode 100644 index 0000000..6aedc5c --- /dev/null +++ b/lib/SQL/Translator/Producer.pm @@ -0,0 +1,64 @@ +package SQL::Translator::Producer; + +#----------------------------------------------------- +# $Id: Producer.pm,v 1.1.1.1 2002-03-01 02:26:25 kycl4rk Exp $ +# +# File : SQL/Translator/Producer.pm +# Programmer : Ken Y. Clark, kclark@logsoft.com +# Created : 2002/02/27 +# Purpose : base object for Producers +#----------------------------------------------------- + +use strict; +use vars qw( $VERSION ); +$VERSION = (qw$Revision: 1.1.1.1 $)[-1]; + +use SQL::Translator; +use base qw[ SQL::Translator ]; + +sub from { return shift()->{'from'} } + +sub header { + my $self = shift; + my $from = $self->from || ''; + my $to = $self->to || ''; + return <<"HEADER"; +# +# $from-to-$to translator +# Version: $SQL::Translator::VERSION +# + +HEADER +} + +1; + +#----------------------------------------------------- +# A burnt child loves the fire. +# Oscar Wilde +#----------------------------------------------------- + +=head1 NAME + +SQL::Translator::Producer - base object for Producers + +=head1 SYNOPSIS + + package SQL::Translator::Producer::Foo; + use SQL::Translator::Producer; + use base( 'SQL::Translator::Producer' ); + 1; + +=head1 DESCRIPTION + +Intended to serve as a base class for all SQL Translator producers. + +=head1 AUTHOR + +Ken Y. Clark, kclark@logsoft.com + +=head1 SEE ALSO + +perl(1). + +=cut diff --git a/lib/SQL/Translator/Producer/Oracle.pm b/lib/SQL/Translator/Producer/Oracle.pm new file mode 100644 index 0000000..2e4374e --- /dev/null +++ b/lib/SQL/Translator/Producer/Oracle.pm @@ -0,0 +1,317 @@ +package SQL::Translator::Producer::Oracle; + +#----------------------------------------------------- +# $Id: Oracle.pm,v 1.1.1.1 2002-03-01 02:26:25 kycl4rk Exp $ +# +# File : SQL/Translator/Producer/Oracle.pm +# Programmer : Ken Y. Clark, kclark@logsoft.com +# Created : 2002/02/27 +# Purpose : Oracle SQL producer +#----------------------------------------------------- + +use strict; +use SQL::Translator::Producer; +use vars qw( $VERSION ); +$VERSION = (qw$Revision: 1.1.1.1 $)[-1]; + +use base qw[ SQL::Translator::Producer ]; + +my $max_identifier_length = 30; +my %used_identifiers = (); + +my %translate = ( + bigint => 'number', + double => 'number', + decimal => 'number', + float => 'number', + int => 'number', + mediumint => 'number', + smallint => 'number', + tinyint => 'number', + + char => 'char', + + varchar => 'varchar2', + + tinyblob => 'CLOB', + blob => 'CLOB', + mediumblob => 'CLOB', + longblob => 'CLOB', + + longtext => 'long', + mediumtext => 'long', + text => 'long', + tinytext => 'long', + + enum => 'varchar2', + set => 'varchar2', + + date => 'date', + datetime => 'date', + time => 'date', + timestamp => 'date', + year => 'date', +); + +sub to { 'Oracle' } + +sub translate { + my ( $self, $data ) = @_; + + #print "got ", scalar keys %$data, " tables:\n"; + #print join(', ', keys %$data), "\n"; + #print Dumper( $data ); + + # + # Output + # + my $output = $self->header; + + # + # Print create for each table + # + my ( $index_i, $trigger_i ) = ( 1, 1 ); + for my $table_name ( sort keys %$data ) { + check_identifier( $table_name ); + + my ( @comments, @field_decs, @trigger_decs ); + + my $table = $data->{ $table_name }; + push @comments, "#\n# Table: $table_name\n#"; + + for my $field ( + map { $_->[1] } + sort { $a->[0] <=> $b->[0] } + map { [ $_->{'order'}, $_ ] } + values %{ $table->{'fields'} } + ) { + # + # Field name + # + my $field_str = check_identifier( $field->{'name'} ); + + # + # Datatype + # + my $data_type = $field->{'data_type'}; + $data_type = defined $translate{ $data_type } ? + $translate{ $data_type } : + die "Unknown datatype: $data_type\n"; + $field_str .= ' '.$data_type; + $field_str .= '('.$field->{'size'}.')' if defined $field->{'size'}; + + # + # Default value + # + if ( $field->{'default'} ) { + # next if $field->{'default'} eq 'NULL'; + $field_str .= sprintf( + ' DEFAULT %s', + $field->{'default'} =~ m/null/i ? 'NULL' : + "'".$field->{'default'}."'" + ); + } + + # + # Not null constraint + # + unless ( $field->{'null'} ) { + my $constraint_name = make_identifier($field->{'name'}, '_nn'); + $field_str .= ' CONSTRAINT ' . $constraint_name . ' NOT NULL'; + } + + # + # Auto_increment + # + if ( $field->{'is_auto_inc'} ) { + my $trigger_no = $trigger_i++; + my $trigger_sequence = + join( '_', 'seq' , $field->{'name'}, $trigger_no ); + my $trigger_name = + join( '_', 'autoinc', $field->{'name'}, $trigger_no ); + + push @trigger_decs, + 'CREATE SEQUENCE ' . $trigger_sequence . ";" . + 'CREATE OR REPLACE TRIGGER ' . $trigger_name . + ' BEFORE INSERT ON ' . $table_name . + ' FOR EACH ROW WHEN (new.' . $field->{'name'} . ' is null) ' . + ' BEGIN ' . + ' SELECT ' . $trigger_sequence . '.nextval ' . + ' INTO :new.' . $field->{'name'} . + " FROM dual;\n" . + ' END ' . $trigger_name . ";/" + ; + } + + push @field_decs, $field_str; + } + + # + # Index Declarations + # + my @index_decs = (); + for my $index ( @{ $table->{'indeces'} } ) { + my $index_name = $index->{'name'} || ''; + my $index_type = $index->{'type'} || 'normal'; + my @fields = @{ $index->{'fields'} } or next; + + if ( $index_type eq 'primary_key' ) { + if ( !$index_name ) { + $index_name = make_identifier( $table_name, 'i_', '_pk' ); + } + elsif ( $index_name !~ m/^i_/ ) { + $index_name = make_identifier( $table_name, 'i_' ); + } + elsif ( $index_name !~ m/_pk$/ ) { + $index_name = make_identifier( $table_name, '_pk' ); + } + else { + $index_name = make_identifier( $index_name ); + } + + push @field_decs, 'CONSTRAINT ' . $index_name . ' PRIMARY KEY ' . + '(' . join( ', ', @fields ) . ')'; + } + + elsif ( $index_type eq 'unique' ) { + if ( !$index_name ) { + $index_name = make_identifier( join( '_', @fields ), 'u_' ); + } + elsif ( $index_name !~ m/^u_/ ) { + $index_name = make_identifier( $index_name, 'u_' ); + } + else { + $index_name = make_identifier( $index_name ); + } + + push @field_decs, 'CONSTRAINT ' . $index_name . ' UNIQUE ' . + '(' . join( ', ', @fields ) . ')'; + } + + elsif ( $index_type eq 'normal' ) { + if ( !$index_name ) { + $index_name = + make_identifier($table_name, 'i_', '_'.$index_i++ ); + } + elsif ( $index_name !~ m/^i_/ ) { + $index_name = make_identifier( $index_name, 'i_' ); + } + else { + $index_name = make_identifier( $index_name ); + } + + push @index_decs, "CREATE INDEX $index_name on $table_name (". + join( ', ', @{ $index->{'fields'} } ). + ");" + ; + } + + else { + warn "On table $table_name, unknown index type: $index_type\n"; + } + } + + my $create_statement = "CREATE TABLE $table_name (\n". + join( ",\n", map { " $_" } @field_decs ). + "\n);" + ; + + $output .= join( "\n\n", + @comments, + $create_statement, + @trigger_decs, + @index_decs, + '' + ); + } + + $output .= "#\n# End\n#\n"; +} + +# +# 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_identifier_length + ) { + $identifier = substr( + $identifier, + 0, + $max_identifier_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_identifier_length; + return $identifier; +} + +1; + +#----------------------------------------------------- +# All bad art is the result of good intentions. +# Oscar Wilde +#----------------------------------------------------- + +=head1 NAME + +SQL::Translator::Producer::Oracle - Oracle SQL producer + +=head1 SYNOPSIS + + use SQL::Translator::Producer::Oracle; + +=head1 DESCRIPTION + +Blah blah blah. + +=head1 AUTHOR + +Ken Y. Clark, kclark@logsoft.com + +=head1 SEE ALSO + +perl(1). + +=cut diff --git a/lib/SQL/Translator/Producer/XML.pm b/lib/SQL/Translator/Producer/XML.pm new file mode 100644 index 0000000..7621a62 --- /dev/null +++ b/lib/SQL/Translator/Producer/XML.pm @@ -0,0 +1,57 @@ +package SQL::Translator::Producer::XML; + +#----------------------------------------------------- +# $Id: XML.pm,v 1.1.1.1 2002-03-01 02:26:25 kycl4rk Exp $ +# +# File : SQL/Translator/Producer/XML.pm +# Programmer : Ken Y. Clark, kclark@logsoft.com +# Created : 2002/02/27 +# Purpose : XML output +#----------------------------------------------------- + +use strict; +use SQL::Translator::Producer; +use vars qw( $VERSION ); +$VERSION = (qw$Revision: 1.1.1.1 $)[-1]; + +use XML::Dumper; + +use base qw[ SQL::Translator::Producer ]; + +sub to { 'XML' } + +sub translate { + my ( $self, $data ) = @_; + my $dumper = XML::Dumper->new; + return $dumper->pl2xml( $data ); +} + +1; + +#----------------------------------------------------- +# The eyes of fire, the nostrils of air, +# The mouth of water, the beard of earth. +# William Blake +#----------------------------------------------------- + +=head1 NAME + +SQL::Translator::Producer::XML - XML output + +=head1 SYNOPSIS + + use SQL::Translator::Producer::XML; + +=head1 DESCRIPTION + +Blah blah blah. + +=head1 AUTHOR + +Ken Y. Clark, kclark@logsoft.com + +=head1 SEE ALSO + +perl(1). + +=cut