lib/SQL/Translator/Producer/Oracle.pm

   1 package SQL::Translator::Producer::Oracle;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: Oracle.pm,v 1.1.1.1.2.1 2002-03-15 20:13:46 dlc Exp $
   5 # -------------------------------------------------------------------
   6 # Copyright (C) 2002 Ken Y. Clark <kycl4rk@users.sourceforge.net>,
   7 #                    darren chamberlain <darren@cpan.org>
   8 #
   9 # This program is free software; you can redistribute it and/or
  10 # modify it under the terms of the GNU General Public License as
  11 # published by the Free Software Foundation; version 2.
  12 #
  13 # This program is distributed in the hope that it will be useful, but
  14 # WITHOUT ANY WARRANTY; without even the implied warranty of
  15 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  16 # General Public License for more details.
  17 #
  18 # You should have received a copy of the GNU General Public License
  19 # along with this program; if not, write to the Free Software
  20 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
  21 # 02111-1307  USA
  22 # -------------------------------------------------------------------
  23
  24
  25 use strict;
  26 use vars qw( $VERSION );
  27 $VERSION = sprintf "%d.%02d", q$Revision: 1.1.1.1.2.1 $ =~ /(\d+)\.(\d+)/;
  28
  29 my $max_identifier_length = 30;
  30 my %used_identifiers = ();
  31
  32 my %translate  = (
  33     bigint     => 'number',
  34     double     => 'number',
  35     decimal    => 'number',
  36     float      => 'number',
  37     int        => 'number',
  38     mediumint  => 'number',
  39     smallint   => 'number',
  40     tinyint    => 'number',
  41
  42     char       => 'char',
  43
  44     varchar    => 'varchar2',
  45
  46     tinyblob   => 'CLOB',
  47     blob       => 'CLOB',
  48     mediumblob => 'CLOB',
  49     longblob   => 'CLOB',
  50
  51     longtext   => 'long',
  52     mediumtext => 'long',
  53     text       => 'long',
  54     tinytext   => 'long',
  55
  56     enum       => 'varchar2',
  57     set        => 'varchar2',
  58
  59     date       => 'date',
  60     datetime   => 'date',
  61     time       => 'date',
  62     timestamp  => 'date',
  63     year       => 'date',
  64 );
  65
  66 # This is for testing only, and probably needs to be removed
  67 *translate = *produce;
  68
  69 sub produce {
  70     my ( $translator, $data ) = @_;
  71
  72     #print "got ", scalar keys %$data, " tables:\n";
  73     #print join(', ', keys %$data), "\n";
  74     #print Dumper( $data );
  75
  76     #
  77     # Output
  78     #
  79     my $output = sprintf "
  80 #
  81 # Created by %s, version %s
  82 # Datasource: %s
  83 #
  84
  85 ", __PACKAGE__, $VERSION, $translator->parser_type;
  86
  87     #
  88     # Print create for each table
  89     #
  90     my ( $index_i, $trigger_i ) = ( 1, 1 );
  91     for my $table_name ( sort keys %$data ) {
  92         check_identifier( $table_name );
  93
  94         my ( @comments, @field_decs, @trigger_decs );
  95
  96         my $table = $data->{ $table_name };
  97         push @comments, "#\n# Table: $table_name\n#";
  98
  99         for my $field (
 100             map  { $_->[1] }
 101             sort { $a->[0] <=> $b->[0] }
 102             map  { [ $_->{'order'}, $_ ] }
 103             values %{ $table->{'fields'} }
 104         ) {
 105             #
 106             # Field name
 107             #
 108             my $field_str  = check_identifier( $field->{'name'} );
 109
 110             #
 111             # Datatype
 112             #
 113             my $data_type  = $field->{'data_type'};
 114                $data_type  = defined $translate{ $data_type } ?
 115                              $translate{ $data_type } :
 116                              die "Unknown datatype: $data_type\n";
 117                $field_str .= ' '.$data_type;
 118                $field_str .= '('.$field->{'size'}.')' if defined $field->{'size'};
 119
 120             #
 121             # Default value
 122             #
 123             if ( $field->{'default'} ) {
 124     #            next if $field->{'default'} eq 'NULL';
 125                 $field_str .= sprintf(
 126                     ' DEFAULT %s',
 127                     $field->{'default'} =~ m/null/i ? 'NULL' :
 128                     "'".$field->{'default'}."'"
 129                 );
 130             }
 131
 132             #
 133             # Not null constraint
 134             #
 135             unless ( $field->{'null'} ) {
 136                 my $constraint_name = make_identifier($field->{'name'}, '_nn');
 137                 $field_str .= ' CONSTRAINT ' . $constraint_name . ' NOT NULL';
 138             }
 139
 140             #
 141             # Auto_increment
 142             #
 143             if ( $field->{'is_auto_inc'} ) {
 144                 my $trigger_no       = $trigger_i++;
 145                 my $trigger_sequence =
 146                     join( '_', 'seq'    , $field->{'name'}, $trigger_no );
 147                 my $trigger_name     =
 148                     join( '_', 'autoinc', $field->{'name'}, $trigger_no );
 149
 150                 push @trigger_decs,
 151                     'CREATE SEQUENCE ' . $trigger_sequence . ";" .
 152                     'CREATE OR REPLACE TRIGGER ' . $trigger_name .
 153                     ' BEFORE INSERT ON ' . $table_name .
 154                     ' FOR EACH ROW WHEN (new.' . $field->{'name'} . ' is null) ' .
 155                     ' BEGIN ' .
 156                         ' SELECT ' . $trigger_sequence . '.nextval ' .
 157                         ' INTO :new.' . $field->{'name'} .
 158                         " FROM dual;\n" .
 159                     ' END ' . $trigger_name . ";/"
 160                 ;
 161             }
 162
 163             push @field_decs, $field_str;
 164         }
 165
 166         #
 167         # Index Declarations
 168         #
 169         my @index_decs = ();
 170         for my $index ( @{ $table->{'indeces'} } ) {
 171             my $index_name = $index->{'name'} || '';
 172             my $index_type = $index->{'type'} || 'normal';
 173             my @fields     = @{ $index->{'fields'} } or next;
 174
 175             if ( $index_type eq 'primary_key' ) {
 176                 if ( !$index_name ) {
 177                     $index_name = make_identifier( $table_name, 'i_', '_pk' );
 178                 }
 179                 elsif ( $index_name !~ m/^i_/ ) {
 180                     $index_name = make_identifier( $table_name, 'i_' );
 181                 }
 182                 elsif ( $index_name !~ m/_pk$/ ) {
 183                     $index_name = make_identifier( $table_name, '_pk' );
 184                 }
 185                 else {
 186                     $index_name = make_identifier( $index_name );
 187                 }
 188
 189                 push @field_decs, 'CONSTRAINT ' . $index_name . ' PRIMARY KEY ' .
 190                     '(' . join( ', ', @fields ) . ')';
 191             }
 192
 193             elsif ( $index_type eq 'unique' ) {
 194                 if ( !$index_name ) {
 195                     $index_name = make_identifier( join( '_', @fields ), 'u_' );
 196                 }
 197                 elsif ( $index_name !~ m/^u_/ ) {
 198                     $index_name = make_identifier( $index_name, 'u_' );
 199                 }
 200                 else {
 201                     $index_name = make_identifier( $index_name );
 202                 }
 203
 204                 push @field_decs, 'CONSTRAINT ' . $index_name . ' UNIQUE ' .
 205                     '(' . join( ', ', @fields ) . ')';
 206             }
 207
 208             elsif ( $index_type eq 'normal' ) {
 209                 if ( !$index_name ) {
 210                     $index_name =
 211                         make_identifier($table_name, 'i_', '_'.$index_i++ );
 212                 }
 213                 elsif ( $index_name !~ m/^i_/ ) {
 214                     $index_name = make_identifier( $index_name, 'i_' );
 215                 }
 216                 else {
 217                     $index_name = make_identifier( $index_name );
 218                 }
 219
 220                 push @index_decs, "CREATE INDEX $index_name on $table_name (".
 221                     join( ', ', @{ $index->{'fields'} } ).
 222                     ");"
 223                 ;
 224             }
 225
 226             else {
 227                 warn "On table $table_name, unknown index type: $index_type\n";
 228             }
 229         }
 230
 231         my $create_statement = "CREATE TABLE $table_name (\n".
 232             join( ",\n", map { "  $_" } @field_decs ).
 233              "\n);"
 234         ;
 235
 236         $output .= join( "\n\n",
 237             @comments,
 238             $create_statement,
 239             @trigger_decs,
 240             @index_decs,
 241             ''
 242         );
 243     }
 244
 245     $output .= "#\n# End\n#\n";
 246 }
 247
 248 #
 249 # Used to make index names
 250 #
 251 sub make_identifier {
 252     my ( $identifier, @mutations ) = @_;
 253     my $length_of_mutations;
 254     for my $mutation ( @mutations ) {
 255         $length_of_mutations += length( $mutation );
 256     }
 257
 258     if (
 259         length( $identifier ) + $length_of_mutations >
 260         $max_identifier_length
 261     ) {
 262         $identifier = substr(
 263             $identifier,
 264             0,
 265             $max_identifier_length - $length_of_mutations
 266         );
 267     }
 268
 269     for my $mutation ( @mutations ) {
 270         if ( $mutation =~ m/.+_$/ ) {
 271             $identifier = $mutation.$identifier;
 272         }
 273         elsif ( $mutation =~ m/^_.+/ ) {
 274             $identifier = $identifier.$mutation;
 275         }
 276     }
 277
 278     if ( $used_identifiers{ $identifier } ) {
 279         my $index = 1;
 280         if ( $identifier =~ m/_(\d+)$/ ) {
 281             $index = $1;
 282             $identifier = substr(
 283                 $identifier,
 284                 0,
 285                 length( $identifier ) - ( length( $index ) + 1 )
 286             );
 287         }
 288         $index++;
 289         return make_identifier( $identifier, '_'.$index );
 290     }
 291
 292     $used_identifiers{ $identifier } = 1;
 293
 294     return $identifier;
 295 }
 296
 297 #
 298 # Checks to see if an identifier is not too long
 299 #
 300 sub check_identifier {
 301     my $identifier = shift;
 302     die "Identifier '$identifier' is too long, unrecoverable error.\n"
 303         if length( $identifier ) > $max_identifier_length;
 304     return $identifier;
 305 }
 306
 307 1;
 308
 309 #-----------------------------------------------------
 310 # All bad art is the result of good intentions.
 311 # Oscar Wilde
 312 #-----------------------------------------------------
 313
 314 =head1 NAME
 315
 316 SQL::Translator::Producer::Oracle - Oracle SQL producer
 317
 318 =head1 SYNOPSIS
 319
 320   use SQL::Translator::Parser::MySQL;
 321   use SQL::Translator::Producer::Oracle;
 322
 323   my $original_create = ""; # get this from somewhere...
 324   my $translator = SQL::Translator->new;
 325
 326   $translator->parser("SQL::Translator::Parser::MySQL");
 327   $translator->producer("SQL::Translator::Producer::Oracle");
 328
 329   my $new_create = $translator->translate($original_create);
 330
 331 =head1 DESCRIPTION
 332
 333 SQL::Translator::Producer::Oracle takes a parsed data structure,
 334 created by a SQL::Translator::Parser subclass, and turns it into a
 335 create string suitable for use with an Oracle database.
 336
 337 =head1 AUTHOR
 338
 339 Ken Y. Clark, kclark@logsoft.com
 340
 341 =head1 SEE ALSO
 342
 343 perl(1).
 344
 345 =cut