1 package SQL::Translator::Producer::Oracle;
3 # -------------------------------------------------------------------
4 # $Id: Oracle.pm,v 1.10 2003-04-25 11:47:25 dlc Exp $
5 # -------------------------------------------------------------------
6 # Copyright (C) 2003 Ken Y. Clark <kclark@cpan.org>,
7 # darren chamberlain <darren@cpan.org>,
8 # Chris Mungall <cjm@fruitfly.org>
10 # This program is free software; you can redistribute it and/or
11 # modify it under the terms of the GNU General Public License as
12 # published by the Free Software Foundation; version 2.
14 # This program is distributed in the hope that it will be useful, but
15 # WITHOUT ANY WARRANTY; without even the implied warranty of
16 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
17 # General Public License for more details.
19 # You should have received a copy of the GNU General Public License
20 # along with this program; if not, write to the Free Software
21 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
23 # -------------------------------------------------------------------
26 use vars qw[ $VERSION $DEBUG $WARN ];
27 $VERSION = sprintf "%d.%02d", q$Revision: 1.10 $ =~ /(\d+)\.(\d+)/;
28 $DEBUG = 0 unless defined $DEBUG;
30 use SQL::Translator::Utils qw(header_comment);
41 mediumint => 'number',
45 varchar => 'varchar2',
71 'double precision' => '',
76 'character varying' => '',
95 # Oracle reserved words from:
96 # http://technet.oracle.com/docs/products/oracle8i/doc_library/\
97 # 817_doc/server.817/a85397/ap_keywd.htm
99 my %ora_reserved = map { $_, 1 } qw(
100 ACCESS ADD ALL ALTER AND ANY AS ASC AUDIT
102 CHAR CHECK CLUSTER COLUMN COMMENT COMPRESS CONNECT CREATE CURRENT
103 DATE DECIMAL DEFAULT DELETE DESC DISTINCT DROP
104 ELSE EXCLUSIVE EXISTS
108 IDENTIFIED IMMEDIATE IN INCREMENT INDEX INITIAL INSERT
109 INTEGER INTERSECT INTO IS
111 MAXEXTENTS MINUS MLSLABEL MODE MODIFY
112 NOAUDIT NOCOMPRESS NOT NOWAIT NULL NUMBER
113 OF OFFLINE ON ONLINE OPTION OR ORDER
114 PCTFREE PRIOR PRIVILEGES PUBLIC
115 RAW RENAME RESOURCE REVOKE ROW ROWID ROWNUM ROWS
116 SELECT SESSION SET SHARE SIZE SMALLINT START
117 SUCCESSFUL SYNONYM SYSDATE
118 TABLE THEN TO TRIGGER
119 UID UNION UNIQUE UPDATE USER
120 VALIDATE VALUES VARCHAR VARCHAR2 VIEW
124 my $max_id_length = 30;
125 my %used_identifiers = ();
130 # -------------------------------------------------------------------
132 my ( $translator, $data ) = @_;
133 $DEBUG = $translator->debug;
134 $WARN = $translator->show_warnings;
135 my $no_comments = $translator->no_comments;
136 my $add_drop_table = $translator->add_drop_table;
139 $output .= header_comment unless ($no_comments);
141 if ( $translator->parser_type =~ /mysql/i ) {
143 "-- We assume that default NLS_DATE_FORMAT has been changed\n".
144 "-- but we set it here anyway to be self-consistent.\n".
145 "ALTER SESSION SET NLS_DATE_FORMAT = 'YYYY-MM-DD HH24:MI:SS';\n\n";
149 # Print create for each table
153 sort { $a->[0] <=> $b->[0] }
154 map { [ $_->{'order'}, $_ ] }
157 my $table_name = $table->{'table_name'};
158 $table_name = mk_name( $table_name, '', undef, 1 );
159 my $table_name_ur = unreserve($table_name);
161 my ( @comments, @field_decs, @trigger_decs );
163 push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;
165 my %field_name_scope;
168 sort { $a->[0] <=> $b->[0] }
169 map { [ $_->{'order'}, $_ ] }
170 values %{ $table->{'fields'} }
175 my $field_name = mk_name(
176 $field->{'name'}, '', \%field_name_scope, 1
178 my $field_name_ur = unreserve( $field_name, $table_name );
179 my $field_str = $field_name_ur;
185 my $data_type = lc $field->{'data_type'};
186 my $list = $field->{'list'} || [];
187 my $commalist = join ",", @$list;
189 if ( $data_type eq 'enum' ) {
191 $len = ($len < length($_)) ? length($_) : $len for (@$list);
192 $check = "CHECK ($field_name IN ($commalist))";
193 $field_str .= " varchar2($len)";
195 elsif ( $data_type eq 'set' ) {
196 # XXX add a CHECK constraint maybe
197 # (trickier and slower, than enum :)
198 my $len = length $commalist;
199 $field_str .= " varchar2($len) /* set $commalist */ ";
202 $data_type = defined $translate{ $data_type } ?
203 $translate{ $data_type } :
204 die "Unknown datatype: $data_type\n";
205 $field_str .= ' '.$data_type;
206 $field_str .= '('.join(',', @{ $field->{'size'} }).')'
207 if @{ $field->{'size'} || [] };
213 if ( defined $field->{'default'} ) {
214 $field_str .= sprintf(
216 $field->{'default'} =~ m/null/i ? 'NULL' :
217 "'".$field->{'default'}."'"
222 # Not null constraint
224 unless ( $field->{'null'} ) {
225 my $constraint_name = mk_name($field_name_ur, 'nn');
226 $field_str .= ' CONSTRAINT ' . $constraint_name . ' NOT NULL';
229 $field_str .= " $check" if $check;
234 if ( $field->{'is_auto_inc'} ) {
235 my $base_name = $table_name . "_". $field_name;
236 my $seq_name = mk_name( $base_name, 'sq' );
237 my $trigger_name = mk_name( $base_name, 'ai' );
240 "CREATE SEQUENCE $seq_name;\n" .
241 "CREATE OR REPLACE TRIGGER $trigger_name\n" .
242 "BEFORE INSERT ON $table_name\n" .
243 "FOR EACH ROW WHEN (\n" .
244 " new.$field_name_ur IS NULL".
245 " OR new.$field_name_ur = 0\n".
248 " SELECT $seq_name.nextval\n" .
249 " INTO :new." . $field->{'name'}."\n" .
255 if ( uc $field->{'data_type'} eq 'TIMESTAMP' ) {
256 my $base_name = $table_name . "_". $field_name_ur;
257 my $trig_name = mk_name( $base_name, 'ts' );
259 "CREATE OR REPLACE TRIGGER $trig_name\n".
260 "BEFORE INSERT OR UPDATE ON $table_name_ur\n".
261 "FOR EACH ROW WHEN (new.$field_name_ur} IS NULL)\n".
263 " SELECT sysdate INTO :new.$field_name_ur} FROM dual;\n".
267 push @field_decs, $field_str;
274 my $idx_name_default;
275 for my $index ( @{ $table->{'indices'} } ) {
276 my $index_name = $index->{'name'} || '';
277 my $index_type = $index->{'type'} || 'normal';
278 my @fields = map { unreserve( $_, $table_name ) }
279 @{ $index->{'fields'} };
282 if ( $index_type eq 'primary_key' ) {
283 $index_name = mk_name( $table_name, 'pk' );
284 push @field_decs, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
285 '(' . join( ', ', @fields ) . ')';
287 elsif ( $index_type eq 'unique' ) {
288 $index_name = mk_name(
289 $table_name, $index_name || ++$idx_name_default
291 push @field_decs, 'CONSTRAINT ' . $index_name . ' UNIQUE ' .
292 '(' . join( ', ', @fields ) . ')';
295 elsif ( $index_type eq 'normal' ) {
296 $index_name = mk_name(
297 $table_name, $index_name || ++$idx_name_default
300 "CREATE INDEX $index_name on $table_name_ur (".
301 join( ', ', @fields ).
305 warn "Unknown index type ($index_type) on table $table_name.\n"
310 my $create_statement;
311 $create_statement = "DROP TABLE $table_name_ur;\n" if $add_drop_table;
312 $create_statement .= "CREATE TABLE $table_name_ur (\n".
313 join( ",\n", map { " $_" } @field_decs ).
317 $output .= join( "\n\n",
328 warn "Truncated " . keys( %truncated ) . " names:\n";
329 warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
333 warn "Encounted " . keys( %unreserve ) .
334 " unsafe names in schema (reserved or invalid):\n";
335 warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
342 # -------------------------------------------------------------------
344 my ($basename, $type, $scope, $critical) = @_;
345 my $basename_orig = $basename;
347 ? $max_id_length - (length($type) + 1)
349 $basename = substr( $basename, 0, $max_name )
350 if length( $basename ) > $max_name;
351 my $name = $type ? "${type}_$basename" : $basename;
353 if ( $basename ne $basename_orig and $critical ) {
354 my $show_type = $type ? "+'$type'" : "";
355 warn "Truncating '$basename_orig'$show_type to $max_id_length ",
356 "character limit to make '$name'\n" if $WARN;
357 $truncated{ $basename_orig } = $name;
360 $scope ||= \%global_names;
361 if ( my $prev = $scope->{ $name } ) {
362 my $name_orig = $name;
363 $name .= sprintf( "%02d", ++$prev );
364 substr($name, $max_id_length - 3) = "00"
365 if length( $name ) > $max_id_length;
367 warn "The name '$name_orig' has been changed to ",
368 "'$name' to make it unique.\n" if $WARN;
370 $scope->{ $name_orig }++;
377 # -------------------------------------------------------------------
379 my ( $name, $schema_obj_name ) = @_;
380 my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
382 # also trap fields that don't begin with a letter
383 return $_[0] if !$ora_reserved{ uc $name } && $name =~ /^[a-z]/i;
385 if ( $schema_obj_name ) {
386 ++$unreserve{"$schema_obj_name.$name"};
389 ++$unreserve{"$name (table name)"};
392 my $unreserve = sprintf '%s_', $name;
393 return $unreserve.$suffix;
398 # -------------------------------------------------------------------
399 # All bad art is the result of good intentions.
401 # -------------------------------------------------------------------
405 SQL::Translator::Producer::Oracle - Oracle SQL producer
409 use SQL::Translator::Parser::MySQL;
410 use SQL::Translator::Producer::Oracle;
412 my $original_create = ""; # get this from somewhere...
413 my $translator = SQL::Translator->new;
415 $translator->parser("SQL::Translator::Parser::MySQL");
416 $translator->producer("SQL::Translator::Producer::Oracle");
418 my $new_create = $translator->translate($original_create);
422 SQL::Translator::Producer::Oracle takes a parsed data structure,
423 created by a SQL::Translator::Parser subclass, and turns it into a
424 create string suitable for use with an Oracle database.
428 A hearty "thank-you" to Tim Bunce for much of the logic stolen from
429 his "mysql2ora" script.
433 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>