--- /dev/null
+#!/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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
+ | <error>
+
+ 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];
+ }
+ }
+ | <error>
+
+ line : index
+ | field
+ | <error>
+
+ 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],
+ }
+ }
+ | <error>
+
+ 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
--- /dev/null
+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" }
+# | <error>
+
+ statement : create
+ | junk
+# {
+# print "statement: ", join("\n", @{$item[1]}), "\n";
+# $return = @{$item[1]};
+# print "statement: '", $item[1], "'\n";
+# $return = $item[1];
+# }
+ | <error>
+
+ 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];
+ }
+ }
+ | <error>
+
+ 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],
+ }
+ }
+ | <error>
+
+ 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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
projects / dbsrgits/SQL-Translator.git / commitdiff