Commit | Line | Data |
16dc9970 |
1 | package SQL::Translator::Producer::Oracle; |
2 | |
077ebf34 |
3 | # ------------------------------------------------------------------- |
9a7841dd |
4 | # $Id: Oracle.pm,v 1.2 2002-03-21 18:50:53 dlc Exp $ |
077ebf34 |
5 | # ------------------------------------------------------------------- |
6 | # Copyright (C) 2002 Ken Y. Clark <kycl4rk@users.sourceforge.net>, |
7 | # darren chamberlain <darren@cpan.org> |
16dc9970 |
8 | # |
077ebf34 |
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 | |
16dc9970 |
24 | |
25 | use strict; |
16dc9970 |
26 | use vars qw( $VERSION ); |
9a7841dd |
27 | $VERSION = sprintf "%d.%02d", q$Revision: 1.2 $ =~ /(\d+)\.(\d+)/; |
16dc9970 |
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 | |
077ebf34 |
66 | # This is for testing only, and probably needs to be removed |
67 | *translate = *produce; |
16dc9970 |
68 | |
077ebf34 |
69 | sub produce { |
70 | my ( $translator, $data ) = @_; |
16dc9970 |
71 | |
72 | #print "got ", scalar keys %$data, " tables:\n"; |
73 | #print join(', ', keys %$data), "\n"; |
74 | #print Dumper( $data ); |
75 | |
76 | # |
77 | # Output |
78 | # |
077ebf34 |
79 | my $output = sprintf " |
80 | # |
81 | # Created by %s, version %s |
82 | # Datasource: %s |
83 | # |
84 | |
85 | ", __PACKAGE__, $VERSION, $translator->parser_type; |
16dc9970 |
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 | |
077ebf34 |
320 | use SQL::Translator::Parser::MySQL; |
16dc9970 |
321 | use SQL::Translator::Producer::Oracle; |
322 | |
077ebf34 |
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 | |
16dc9970 |
331 | =head1 DESCRIPTION |
332 | |
077ebf34 |
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. |
16dc9970 |
336 | |
efd49776 |
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 | |
16dc9970 |
350 | |
351 | =head1 AUTHOR |
352 | |
353 | Ken Y. Clark, kclark@logsoft.com |
354 | |
355 | =head1 SEE ALSO |
356 | |
357 | perl(1). |
358 | |
359 | =cut |