lib/SQL/Translator/Producer/Oracle.pm

   1 package SQL::Translator::Producer::Oracle;
   2
   3 #-----------------------------------------------------
   4 # $Id: Oracle.pm,v 1.1.1.1 2002-03-01 02:26:25 kycl4rk Exp $
   5 #
   6 # File       : SQL/Translator/Producer/Oracle.pm
   7 # Programmer : Ken Y. Clark, kclark@logsoft.com
   8 # Created    : 2002/02/27
   9 # Purpose    : Oracle SQL producer
  10 #-----------------------------------------------------
  11
  12 use strict;
  13 use SQL::Translator::Producer;
  14 use vars qw( $VERSION );
  15 $VERSION = (qw$Revision: 1.1.1.1 $)[-1];
  16
  17 use base qw[ SQL::Translator::Producer ];
  18
  19 my $max_identifier_length = 30;
  20 my %used_identifiers = ();
  21
  22 my %translate  = (
  23     bigint     => 'number',
  24     double     => 'number',
  25     decimal    => 'number',
  26     float      => 'number',
  27     int        => 'number',
  28     mediumint  => 'number',
  29     smallint   => 'number',
  30     tinyint    => 'number',
  31
  32     char       => 'char',
  33
  34     varchar    => 'varchar2',
  35
  36     tinyblob   => 'CLOB',
  37     blob       => 'CLOB',
  38     mediumblob => 'CLOB',
  39     longblob   => 'CLOB',
  40
  41     longtext   => 'long',
  42     mediumtext => 'long',
  43     text       => 'long',
  44     tinytext   => 'long',
  45
  46     enum       => 'varchar2',
  47     set        => 'varchar2',
  48
  49     date       => 'date',
  50     datetime   => 'date',
  51     time       => 'date',
  52     timestamp  => 'date',
  53     year       => 'date',
  54 );
  55
  56 sub to { 'Oracle' }
  57
  58 sub translate {
  59     my ( $self, $data ) = @_;
  60
  61     #print "got ", scalar keys %$data, " tables:\n";
  62     #print join(', ', keys %$data), "\n";
  63     #print Dumper( $data );
  64
  65     #
  66     # Output
  67     #
  68     my $output = $self->header;
  69
  70     #
  71     # Print create for each table
  72     #
  73     my ( $index_i, $trigger_i ) = ( 1, 1 );
  74     for my $table_name ( sort keys %$data ) {
  75         check_identifier( $table_name );
  76
  77         my ( @comments, @field_decs, @trigger_decs );
  78
  79         my $table = $data->{ $table_name };
  80         push @comments, "#\n# Table: $table_name\n#";
  81
  82         for my $field (
  83             map  { $_->[1] }
  84             sort { $a->[0] <=> $b->[0] }
  85             map  { [ $_->{'order'}, $_ ] }
  86             values %{ $table->{'fields'} }
  87         ) {
  88             #
  89             # Field name
  90             #
  91             my $field_str  = check_identifier( $field->{'name'} );
  92
  93             #
  94             # Datatype
  95             #
  96             my $data_type  = $field->{'data_type'};
  97                $data_type  = defined $translate{ $data_type } ?
  98                              $translate{ $data_type } :
  99                              die "Unknown datatype: $data_type\n";
 100                $field_str .= ' '.$data_type;
 101                $field_str .= '('.$field->{'size'}.')' if defined $field->{'size'};
 102
 103             #
 104             # Default value
 105             #
 106             if ( $field->{'default'} ) {
 107     #            next if $field->{'default'} eq 'NULL';
 108                 $field_str .= sprintf(
 109                     ' DEFAULT %s',
 110                     $field->{'default'} =~ m/null/i ? 'NULL' :
 111                     "'".$field->{'default'}."'"
 112                 );
 113             }
 114
 115             #
 116             # Not null constraint
 117             #
 118             unless ( $field->{'null'} ) {
 119                 my $constraint_name = make_identifier($field->{'name'}, '_nn');
 120                 $field_str .= ' CONSTRAINT ' . $constraint_name . ' NOT NULL';
 121             }
 122
 123             #
 124             # Auto_increment
 125             #
 126             if ( $field->{'is_auto_inc'} ) {
 127                 my $trigger_no       = $trigger_i++;
 128                 my $trigger_sequence =
 129                     join( '_', 'seq'    , $field->{'name'}, $trigger_no );
 130                 my $trigger_name     =
 131                     join( '_', 'autoinc', $field->{'name'}, $trigger_no );
 132
 133                 push @trigger_decs,
 134                     'CREATE SEQUENCE ' . $trigger_sequence . ";" .
 135                     'CREATE OR REPLACE TRIGGER ' . $trigger_name .
 136                     ' BEFORE INSERT ON ' . $table_name .
 137                     ' FOR EACH ROW WHEN (new.' . $field->{'name'} . ' is null) ' .
 138                     ' BEGIN ' .
 139                         ' SELECT ' . $trigger_sequence . '.nextval ' .
 140                         ' INTO :new.' . $field->{'name'} .
 141                         " FROM dual;\n" .
 142                     ' END ' . $trigger_name . ";/"
 143                 ;
 144             }
 145
 146             push @field_decs, $field_str;
 147         }
 148
 149         #
 150         # Index Declarations
 151         #
 152         my @index_decs = ();
 153         for my $index ( @{ $table->{'indeces'} } ) {
 154             my $index_name = $index->{'name'} || '';
 155             my $index_type = $index->{'type'} || 'normal';
 156             my @fields     = @{ $index->{'fields'} } or next;
 157
 158             if ( $index_type eq 'primary_key' ) {
 159                 if ( !$index_name ) {
 160                     $index_name = make_identifier( $table_name, 'i_', '_pk' );
 161                 }
 162                 elsif ( $index_name !~ m/^i_/ ) {
 163                     $index_name = make_identifier( $table_name, 'i_' );
 164                 }
 165                 elsif ( $index_name !~ m/_pk$/ ) {
 166                     $index_name = make_identifier( $table_name, '_pk' );
 167                 }
 168                 else {
 169                     $index_name = make_identifier( $index_name );
 170                 }
 171
 172                 push @field_decs, 'CONSTRAINT ' . $index_name . ' PRIMARY KEY ' .
 173                     '(' . join( ', ', @fields ) . ')';
 174             }
 175
 176             elsif ( $index_type eq 'unique' ) {
 177                 if ( !$index_name ) {
 178                     $index_name = make_identifier( join( '_', @fields ), 'u_' );
 179                 }
 180                 elsif ( $index_name !~ m/^u_/ ) {
 181                     $index_name = make_identifier( $index_name, 'u_' );
 182                 }
 183                 else {
 184                     $index_name = make_identifier( $index_name );
 185                 }
 186
 187                 push @field_decs, 'CONSTRAINT ' . $index_name . ' UNIQUE ' .
 188                     '(' . join( ', ', @fields ) . ')';
 189             }
 190
 191             elsif ( $index_type eq 'normal' ) {
 192                 if ( !$index_name ) {
 193                     $index_name =
 194                         make_identifier($table_name, 'i_', '_'.$index_i++ );
 195                 }
 196                 elsif ( $index_name !~ m/^i_/ ) {
 197                     $index_name = make_identifier( $index_name, 'i_' );
 198                 }
 199                 else {
 200                     $index_name = make_identifier( $index_name );
 201                 }
 202
 203                 push @index_decs, "CREATE INDEX $index_name on $table_name (".
 204                     join( ', ', @{ $index->{'fields'} } ).
 205                     ");"
 206                 ;
 207             }
 208
 209             else {
 210                 warn "On table $table_name, unknown index type: $index_type\n";
 211             }
 212         }
 213
 214         my $create_statement = "CREATE TABLE $table_name (\n".
 215             join( ",\n", map { "  $_" } @field_decs ).
 216              "\n);"
 217         ;
 218
 219         $output .= join( "\n\n",
 220             @comments,
 221             $create_statement,
 222             @trigger_decs,
 223             @index_decs,
 224             ''
 225         );
 226     }
 227
 228     $output .= "#\n# End\n#\n";
 229 }
 230
 231 #
 232 # Used to make index names
 233 #
 234 sub make_identifier {
 235     my ( $identifier, @mutations ) = @_;
 236     my $length_of_mutations;
 237     for my $mutation ( @mutations ) {
 238         $length_of_mutations += length( $mutation );
 239     }
 240
 241     if (
 242         length( $identifier ) + $length_of_mutations >
 243         $max_identifier_length
 244     ) {
 245         $identifier = substr(
 246             $identifier,
 247             0,
 248             $max_identifier_length - $length_of_mutations
 249         );
 250     }
 251
 252     for my $mutation ( @mutations ) {
 253         if ( $mutation =~ m/.+_$/ ) {
 254             $identifier = $mutation.$identifier;
 255         }
 256         elsif ( $mutation =~ m/^_.+/ ) {
 257             $identifier = $identifier.$mutation;
 258         }
 259     }
 260
 261     if ( $used_identifiers{ $identifier } ) {
 262         my $index = 1;
 263         if ( $identifier =~ m/_(\d+)$/ ) {
 264             $index = $1;
 265             $identifier = substr(
 266                 $identifier,
 267                 0,
 268                 length( $identifier ) - ( length( $index ) + 1 )
 269             );
 270         }
 271         $index++;
 272         return make_identifier( $identifier, '_'.$index );
 273     }
 274
 275     $used_identifiers{ $identifier } = 1;
 276
 277     return $identifier;
 278 }
 279
 280 #
 281 # Checks to see if an identifier is not too long
 282 #
 283 sub check_identifier {
 284     my $identifier = shift;
 285     die "Identifier '$identifier' is too long, unrecoverable error.\n"
 286         if length( $identifier ) > $max_identifier_length;
 287     return $identifier;
 288 }
 289
 290 1;
 291
 292 #-----------------------------------------------------
 293 # All bad art is the result of good intentions.
 294 # Oscar Wilde
 295 #-----------------------------------------------------
 296
 297 =head1 NAME
 298
 299 SQL::Translator::Producer::Oracle - Oracle SQL producer
 300
 301 =head1 SYNOPSIS
 302
 303   use SQL::Translator::Producer::Oracle;
 304
 305 =head1 DESCRIPTION
 306
 307 Blah blah blah.
 308
 309 =head1 AUTHOR
 310
 311 Ken Y. Clark, kclark@logsoft.com
 312
 313 =head1 SEE ALSO
 314
 315 perl(1).
 316
 317 =cut