lib/SQL/Translator/Producer/Oracle.pm

   1 package SQL::Translator::Producer::Oracle;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: Oracle.pm,v 1.1.1.1.2.2 2002-03-18 20:30:37 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.2 $ =~ /(\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 BUGS
 338
 339 Problem with SQL::Translator::Producer::Oracle: it is keeping track
 340 of the last sequence number used, so as not to duplicate them, which
 341 is reasonable.  However on runs past the first, it seems to be
 342 creating multiple constraint lines, that look like:
 343
 344     CONSTRAINT i_sessions_pk_2 PRIMARY KEY (id),
 345     CONSTRAINT i_sessions_pk_3 PRIMARY KEY (id)
 346
 347 This is a very preliminary finding, and needs to be investigated more
 348 thoroughly, of course.
 349
 350
 351 =head1 AUTHOR
 352
 353 Ken Y. Clark, kclark@logsoft.com
 354
 355 =head1 SEE ALSO
 356
 357 perl(1).
 358
 359 =cut