Allow passing an arrayref to SQLT->filename
[dbsrgits/SQL-Translator.git] / lib / SQL / Translator / Producer / Sybase.pm
CommitLineData
d9b22bfe 1package SQL::Translator::Producer::Sybase;
2
d9b22bfe 3=head1 NAME
4
5SQL::Translator::Producer::Sybase - Sybase producer for SQL::Translator
6
75c75c55 7=head1 SYNOPSIS
8
9 use SQL::Translator;
10
11 my $t = SQL::Translator->new( parser => '...', producer => 'Sybase' );
12 $t->translate;
13
14=head1 DESCRIPTION
15
16This module will produce text output of the schema suitable for Sybase.
17
d9b22bfe 18=cut
19
20use strict;
f27f9229 21use warnings;
0c04c5a2 22our ( $DEBUG, $WARN );
23our $VERSION = '1.59';
d9b22bfe 24$DEBUG = 1 unless defined $DEBUG;
25
26use Data::Dumper;
54c9812d 27use SQL::Translator::Schema::Constants;
590f4d4a 28use SQL::Translator::Utils qw(debug header_comment);
d9b22bfe 29
30my %translate = (
31 #
32 # Sybase types
33 #
54c9812d 34 integer => 'numeric',
35 int => 'numeric',
36 number => 'numeric',
37 money => 'money',
38 varchar => 'varchar',
39 varchar2 => 'varchar',
40 timestamp => 'datetime',
41 text => 'varchar',
42 real => 'double precision',
43 comment => 'text',
44 bit => 'bit',
45 tinyint => 'smallint',
46 float => 'double precision',
ea93df61 47 serial => 'numeric',
54c9812d 48 boolean => 'varchar',
49 char => 'char',
50 long => 'varchar',
d9b22bfe 51);
52
53my %reserved = map { $_, 1 } qw[
ea93df61 54 ALL ANALYSE ANALYZE AND ANY AS ASC
d9b22bfe 55 BETWEEN BINARY BOTH
56 CASE CAST CHECK COLLATE COLUMN CONSTRAINT CROSS
ea93df61 57 CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP CURRENT_USER
d9b22bfe 58 DEFAULT DEFERRABLE DESC DISTINCT DO
59 ELSE END EXCEPT
ea93df61 60 FALSE FOR FOREIGN FREEZE FROM FULL
61 GROUP HAVING
62 ILIKE IN INITIALLY INNER INTERSECT INTO IS ISNULL
63 JOIN LEADING LEFT LIKE LIMIT
d9b22bfe 64 NATURAL NEW NOT NOTNULL NULL
65 OFF OFFSET OLD ON ONLY OR ORDER OUTER OVERLAPS
ea93df61 66 PRIMARY PUBLIC REFERENCES RIGHT
67 SELECT SESSION_USER SOME TABLE THEN TO TRAILING TRUE
d9b22bfe 68 UNION UNIQUE USER USING VERBOSE WHEN WHERE
69];
70
71my $max_id_length = 30;
72my %used_identifiers = ();
73my %global_names;
74my %unreserve;
75my %truncated;
76
77=pod
78
79=head1 Sybase Create Table Syntax
80
81 CREATE [ [ LOCAL ] { TEMPORARY | TEMP } ] TABLE table_name (
82 { column_name data_type [ DEFAULT default_expr ] [ column_constraint [, ... ] ]
83 | table_constraint } [, ... ]
84 )
85 [ INHERITS ( parent_table [, ... ] ) ]
86 [ WITH OIDS | WITHOUT OIDS ]
87
88where column_constraint is:
89
90 [ CONSTRAINT constraint_name ]
91 { NOT NULL | NULL | UNIQUE | PRIMARY KEY |
92 CHECK (expression) |
93 REFERENCES reftable [ ( refcolumn ) ] [ MATCH FULL | MATCH PARTIAL ]
94 [ ON DELETE action ] [ ON UPDATE action ] }
95 [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
96
97and table_constraint is:
98
99 [ CONSTRAINT constraint_name ]
100 { UNIQUE ( column_name [, ... ] ) |
101 PRIMARY KEY ( column_name [, ... ] ) |
102 CHECK ( expression ) |
103 FOREIGN KEY ( column_name [, ... ] ) REFERENCES reftable [ ( refcolumn [, ... ] ) ]
104 [ MATCH FULL | MATCH PARTIAL ] [ ON DELETE action ] [ ON UPDATE action ] }
105 [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
106
107=head1 Create Index Syntax
108
109 CREATE [ UNIQUE ] INDEX index_name ON table
110 [ USING acc_method ] ( column [ ops_name ] [, ...] )
111 [ WHERE predicate ]
112 CREATE [ UNIQUE ] INDEX index_name ON table
113 [ USING acc_method ] ( func_name( column [, ... ]) [ ops_name ] )
114 [ WHERE predicate ]
115
116=cut
117
d9b22bfe 118sub produce {
a1d94525 119 my $translator = shift;
120 $DEBUG = $translator->debug;
121 $WARN = $translator->show_warnings;
122 my $no_comments = $translator->no_comments;
123 my $add_drop_table = $translator->add_drop_table;
124 my $schema = $translator->schema;
d9b22bfe 125
126 my $output;
590f4d4a 127 $output .= header_comment unless ($no_comments);
d9b22bfe 128
54c9812d 129 for my $table ( $schema->get_tables ) {
130 my $table_name = $table->name or next;
d9b22bfe 131 $table_name = mk_name( $table_name, '', undef, 1 );
54c9812d 132 my $table_name_ur = unreserve($table_name) || '';
d9b22bfe 133
54c9812d 134 my ( @comments, @field_defs, @index_defs, @constraint_defs );
d9b22bfe 135
136 push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;
137
54c9812d 138 push @comments, map { "-- $_" } $table->comments;
139
d9b22bfe 140 #
141 # Fields
142 #
143 my %field_name_scope;
54c9812d 144 for my $field ( $table->get_fields ) {
d9b22bfe 145 my $field_name = mk_name(
ea93df61 146 $field->name, '', \%field_name_scope, undef,1
d9b22bfe 147 );
148 my $field_name_ur = unreserve( $field_name, $table_name );
54c9812d 149 my $field_def = qq["$field_name_ur"];
150 $field_def =~ s/\"//g;
151 if ( $field_def =~ /identity/ ){
152 $field_def =~ s/identity/pidentity/;
590f4d4a 153 }
d9b22bfe 154
155 #
156 # Datatype
157 #
54c9812d 158 my $data_type = lc $field->data_type;
590f4d4a 159 my $orig_data_type = $data_type;
54c9812d 160 my %extra = $field->extra;
161 my $list = $extra{'list'} || [];
77d74ea6 162 # \todo deal with embedded quotes
4524cf01 163 my $commalist = join( ', ', map { qq['$_'] } @$list );
d9b22bfe 164 my $seq_name;
165
166 if ( $data_type eq 'enum' ) {
ea93df61 167 my $check_name = mk_name(
590f4d4a 168 $table_name.'_'.$field_name, 'chk' ,undef, 1
169 );
ea93df61 170 push @constraint_defs,
d9b22bfe 171 "CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
54c9812d 172 $data_type .= 'character varying';
d9b22bfe 173 }
174 elsif ( $data_type eq 'set' ) {
54c9812d 175 $data_type .= 'character varying';
d9b22bfe 176 }
54c9812d 177 elsif ( $field->is_auto_increment ) {
178 $field_def .= ' IDENTITY';
d9b22bfe 179 }
180 else {
54c9812d 181 if ( defined $translate{ $data_type } ) {
182 $data_type = $translate{ $data_type };
d9b22bfe 183 }
54c9812d 184 else {
185 warn "Unknown datatype: $data_type ",
186 "($table_name.$field_name)\n" if $WARN;
590f4d4a 187 }
54c9812d 188 }
590f4d4a 189
54c9812d 190 my $size = $field->size;
191 unless ( $size ) {
192 if ( $data_type =~ /numeric/ ) {
193 $size = '9,0';
194 }
195 elsif ( $orig_data_type eq 'text' ) {
590f4d4a 196 #interpret text fields as long varchars
54c9812d 197 $size = '255';
590f4d4a 198 }
54c9812d 199 elsif (
ea93df61 200 $data_type eq 'varchar' &&
54c9812d 201 $orig_data_type eq 'boolean'
202 ) {
203 $size = '6';
590f4d4a 204 }
54c9812d 205 elsif ( $data_type eq 'varchar' ) {
206 $size = '255';
590f4d4a 207 }
d9b22bfe 208 }
209
54c9812d 210 $field_def .= " $data_type";
211 $field_def .= "($size)" if $size;
d9b22bfe 212
213 #
214 # Default value
215 #
54c9812d 216 my $default = $field->default_value;
217 if ( defined $default ) {
218 $field_def .= sprintf( ' DEFAULT %s',
219 ( $field->is_auto_increment && $seq_name )
d9b22bfe 220 ? qq[nextval('"$seq_name"'::text)] :
54c9812d 221 ( $default =~ m/null/i ) ? 'NULL' : "'$default'"
d9b22bfe 222 );
223 }
224
225 #
226 # Not null constraint
227 #
54c9812d 228 unless ( $field->is_nullable ) {
229 $field_def .= ' NOT NULL';
d9b22bfe 230 }
590f4d4a 231 else {
54c9812d 232 $field_def .= ' NULL' if $data_type ne 'bit';
590f4d4a 233 }
d9b22bfe 234
54c9812d 235 push @field_defs, $field_def;
d9b22bfe 236 }
237
238 #
239 # Constraint Declarations
240 #
241 my @constraint_decs = ();
54c9812d 242 my $c_name_default;
243 for my $constraint ( $table->get_constraints ) {
244 my $name = $constraint->name || '';
245 my $type = $constraint->type || NORMAL;
246 my @fields = map { unreserve( $_, $table_name ) }
247 $constraint->fields;
248 my @rfields = map { unreserve( $_, $table_name ) }
249 $constraint->reference_fields;
d9b22bfe 250 next unless @fields;
251
54c9812d 252 if ( $type eq PRIMARY_KEY ) {
253 $name ||= mk_name( $table_name, 'pk', undef,1 );
ea93df61 254 push @constraint_defs,
54c9812d 255 "CONSTRAINT $name PRIMARY KEY ".
d9b22bfe 256 '(' . join( ', ', @fields ) . ')';
257 }
54c9812d 258 elsif ( $type eq FOREIGN_KEY ) {
259 $name ||= mk_name( $table_name, 'fk', undef,1 );
ea93df61 260 push @constraint_defs,
54c9812d 261 "CONSTRAINT $name FOREIGN KEY".
262 ' (' . join( ', ', @fields ) . ') REFERENCES '.
263 $constraint->reference_table.
264 ' (' . join( ', ', @rfields ) . ')';
d9b22bfe 265 }
54c9812d 266 elsif ( $type eq UNIQUE ) {
ea93df61 267 $name ||= mk_name(
268 $table_name,
54c9812d 269 $name || ++$c_name_default,undef, 1
d9b22bfe 270 );
ea93df61 271 push @constraint_defs,
54c9812d 272 "CONSTRAINT $name UNIQUE " .
d9b22bfe 273 '(' . join( ', ', @fields ) . ')';
274 }
54c9812d 275 }
276
277 #
278 # Indices
279 #
280 for my $index ( $table->get_indices ) {
ea93df61 281 push @index_defs,
54c9812d 282 'CREATE INDEX ' . $index->name .
283 " ON $table_name (".
284 join( ', ', $index->fields ) . ");";
d9b22bfe 285 }
286
287 my $create_statement;
ea93df61 288 $create_statement = qq[DROP TABLE $table_name_ur;\n]
d9b22bfe 289 if $add_drop_table;
290 $create_statement .= qq[CREATE TABLE $table_name_ur (\n].
ea93df61 291 join( ",\n",
292 map { " $_" } @field_defs, @constraint_defs
54c9812d 293 ).
d9b22bfe 294 "\n);"
295 ;
296
ea93df61 297 $output .= join( "\n\n",
d9b22bfe 298 @comments,
ea93df61 299 $create_statement,
300 @index_defs,
54c9812d 301 ''
d9b22bfe 302 );
590f4d4a 303 }
304
f996e1ed 305 foreach my $view ( $schema->get_views ) {
306 my (@comments, $view_name);
307
308 $view_name = $view->name();
309 push @comments, "--\n-- View: $view_name\n--" unless $no_comments;
310
311 # text of view is already a 'create view' statement so no need
312 # to do anything fancy.
313
314 $output .= join("\n\n",
315 @comments,
316 $view->sql(),
317 );
318 }
319
320
321 foreach my $procedure ( $schema->get_procedures ) {
322 my (@comments, $procedure_name);
323
324 $procedure_name = $procedure->name();
ea93df61 325 push @comments,
75c75c55 326 "--\n-- Procedure: $procedure_name\n--" unless $no_comments;
f996e1ed 327
75c75c55 328 # text of procedure already has the 'create procedure' stuff
329 # so there is no need to do anything fancy. However, we should
330 # think about doing fancy stuff with granting permissions and
331 # so on.
f996e1ed 332
333 $output .= join("\n\n",
334 @comments,
335 $procedure->sql(),
336 );
337 }
338
d9b22bfe 339 if ( $WARN ) {
340 if ( %truncated ) {
341 warn "Truncated " . keys( %truncated ) . " names:\n";
342 warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
343 }
344
345 if ( %unreserve ) {
346 warn "Encounted " . keys( %unreserve ) .
347 " unsafe names in schema (reserved or invalid):\n";
348 warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
349 }
350 }
351
352 return $output;
353}
354
d9b22bfe 355sub mk_name {
ea93df61 356 my $basename = shift || '';
357 my $type = shift || '';
358 my $scope = shift || '';
54c9812d 359 my $critical = shift || '';
d9b22bfe 360 my $basename_orig = $basename;
ea93df61 361 my $max_name = $type
362 ? $max_id_length - (length($type) + 1)
d9b22bfe 363 : $max_id_length;
ea93df61 364 $basename = substr( $basename, 0, $max_name )
d9b22bfe 365 if length( $basename ) > $max_name;
366 my $name = $type ? "${type}_$basename" : $basename;
54c9812d 367
d9b22bfe 368 if ( $basename ne $basename_orig and $critical ) {
369 my $show_type = $type ? "+'$type'" : "";
370 warn "Truncating '$basename_orig'$show_type to $max_id_length ",
371 "character limit to make '$name'\n" if $WARN;
372 $truncated{ $basename_orig } = $name;
373 }
374
375 $scope ||= \%global_names;
376 if ( my $prev = $scope->{ $name } ) {
377 my $name_orig = $name;
378 $name .= sprintf( "%02d", ++$prev );
ea93df61 379 substr($name, $max_id_length - 3) = "00"
d9b22bfe 380 if length( $name ) > $max_id_length;
381
382 warn "The name '$name_orig' has been changed to ",
383 "'$name' to make it unique.\n" if $WARN;
384
385 $scope->{ $name_orig }++;
386 }
ea93df61 387 $name = substr( $name, 0, $max_id_length )
d9b22bfe 388 if ((length( $name ) > $max_id_length) && $critical);
389 $scope->{ $name }++;
390 return $name;
391}
392
d9b22bfe 393sub unreserve {
54c9812d 394 my $name = shift || '';
395 my $schema_obj_name = shift || '';
d9b22bfe 396 my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
397
398 # also trap fields that don't begin with a letter
ea93df61 399 return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
d9b22bfe 400
401 if ( $schema_obj_name ) {
402 ++$unreserve{"$schema_obj_name.$name"};
403 }
404 else {
405 ++$unreserve{"$name (table name)"};
406 }
407
408 my $unreserve = sprintf '%s_', $name;
409 return $unreserve.$suffix;
410}
411
4121;
413
d9b22bfe 414=pod
415
75c75c55 416=head1 SEE ALSO
417
418SQL::Translator.
419
590f4d4a 420=head1 AUTHORS
d9b22bfe 421
590f4d4a 422Sam Angiuoli E<lt>angiuoli@users.sourceforge.netE<gt>,
75c75c55 423Paul Harrington E<lt>harringp@deshaw.comE<gt>,
f997b9ab 424Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>.
d9b22bfe 425
426=cut