Allow passing an arrayref to SQLT->filename
[dbsrgits/SQL-Translator.git] / lib / SQL / Translator / Producer / Sybase.pm
1 package SQL::Translator::Producer::Sybase;
2
3 =head1 NAME
4
5 SQL::Translator::Producer::Sybase - Sybase producer for SQL::Translator
6
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
16 This module will produce text output of the schema suitable for Sybase.
17
18 =cut
19
20 use strict;
21 use warnings;
22 our ( $DEBUG, $WARN );
23 our $VERSION = '1.59';
24 $DEBUG = 1 unless defined $DEBUG;
25
26 use Data::Dumper;
27 use SQL::Translator::Schema::Constants;
28 use SQL::Translator::Utils qw(debug header_comment);
29
30 my %translate  = (
31     #
32     # Sybase types
33     #
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',
47     serial    => 'numeric',
48     boolean   => 'varchar',
49     char      => 'char',
50     long      => 'varchar',
51 );
52
53 my %reserved = map { $_, 1 } qw[
54     ALL ANALYSE ANALYZE AND ANY AS ASC
55     BETWEEN BINARY BOTH
56     CASE CAST CHECK COLLATE COLUMN CONSTRAINT CROSS
57     CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP CURRENT_USER
58     DEFAULT DEFERRABLE DESC DISTINCT DO
59     ELSE END EXCEPT
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
64     NATURAL NEW NOT NOTNULL NULL
65     OFF OFFSET OLD ON ONLY OR ORDER OUTER OVERLAPS
66     PRIMARY PUBLIC REFERENCES RIGHT
67     SELECT SESSION_USER SOME TABLE THEN TO TRAILING TRUE
68     UNION UNIQUE USER USING VERBOSE WHEN WHERE
69 ];
70
71 my $max_id_length    = 30;
72 my %used_identifiers = ();
73 my %global_names;
74 my %unreserve;
75 my %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
88 where 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
97 and 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
118 sub produce {
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;
125
126     my $output;
127     $output .= header_comment unless ($no_comments);
128
129     for my $table ( $schema->get_tables ) {
130         my $table_name    = $table->name or next;
131         $table_name       = mk_name( $table_name, '', undef, 1 );
132         my $table_name_ur = unreserve($table_name) || '';
133
134         my ( @comments, @field_defs, @index_defs, @constraint_defs );
135
136         push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;
137
138         push @comments, map { "-- $_" } $table->comments;
139
140         #
141         # Fields
142         #
143         my %field_name_scope;
144         for my $field ( $table->get_fields ) {
145             my $field_name    = mk_name(
146                 $field->name, '', \%field_name_scope, undef,1
147             );
148             my $field_name_ur = unreserve( $field_name, $table_name );
149             my $field_def     = qq["$field_name_ur"];
150             $field_def        =~ s/\"//g;
151             if ( $field_def =~ /identity/ ){
152                 $field_def =~ s/identity/pidentity/;
153             }
154
155             #
156             # Datatype
157             #
158             my $data_type      = lc $field->data_type;
159             my $orig_data_type = $data_type;
160             my %extra          = $field->extra;
161             my $list           = $extra{'list'} || [];
162             # \todo deal with embedded quotes
163             my $commalist      = join( ', ', map { qq['$_'] } @$list );
164             my $seq_name;
165
166             if ( $data_type eq 'enum' ) {
167                 my $check_name = mk_name(
168                     $table_name.'_'.$field_name, 'chk' ,undef, 1
169                 );
170                 push @constraint_defs,
171                 "CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
172                 $data_type .= 'character varying';
173             }
174             elsif ( $data_type eq 'set' ) {
175                 $data_type .= 'character varying';
176             }
177             elsif ( $field->is_auto_increment ) {
178                 $field_def .= ' IDENTITY';
179             }
180             else {
181                 if ( defined $translate{ $data_type } ) {
182                     $data_type = $translate{ $data_type };
183                 }
184                 else {
185                     warn "Unknown datatype: $data_type ",
186                         "($table_name.$field_name)\n" if $WARN;
187                 }
188             }
189
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' ) {
196                     #interpret text fields as long varchars
197                     $size = '255';
198                 }
199                 elsif (
200                     $data_type eq 'varchar' &&
201                     $orig_data_type eq 'boolean'
202                 ) {
203                     $size = '6';
204                 }
205                 elsif ( $data_type eq 'varchar' ) {
206                     $size = '255';
207                 }
208             }
209
210             $field_def .= " $data_type";
211             $field_def .= "($size)" if $size;
212
213             #
214             # Default value
215             #
216             my $default = $field->default_value;
217             if ( defined $default ) {
218                 $field_def .= sprintf( ' DEFAULT %s',
219                     ( $field->is_auto_increment && $seq_name )
220                     ? qq[nextval('"$seq_name"'::text)] :
221                     ( $default =~ m/null/i ) ? 'NULL' : "'$default'"
222                 );
223             }
224
225             #
226             # Not null constraint
227             #
228             unless ( $field->is_nullable ) {
229                 $field_def .= ' NOT NULL';
230             }
231             else {
232                 $field_def .= ' NULL' if $data_type ne 'bit';
233             }
234
235             push @field_defs, $field_def;
236         }
237
238         #
239         # Constraint Declarations
240         #
241         my @constraint_decs = ();
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;
250             next unless @fields;
251
252             if ( $type eq PRIMARY_KEY ) {
253                 $name ||= mk_name( $table_name, 'pk', undef,1 );
254                 push @constraint_defs,
255                     "CONSTRAINT $name PRIMARY KEY ".
256                     '(' . join( ', ', @fields ) . ')';
257             }
258             elsif ( $type eq FOREIGN_KEY ) {
259                 $name ||= mk_name( $table_name, 'fk', undef,1 );
260                 push @constraint_defs,
261                     "CONSTRAINT $name FOREIGN KEY".
262                     ' (' . join( ', ', @fields ) . ') REFERENCES '.
263                     $constraint->reference_table.
264                     ' (' . join( ', ', @rfields ) . ')';
265             }
266             elsif ( $type eq UNIQUE ) {
267                 $name ||= mk_name(
268                     $table_name,
269                     $name || ++$c_name_default,undef, 1
270                 );
271                 push @constraint_defs,
272                     "CONSTRAINT $name UNIQUE " .
273                     '(' . join( ', ', @fields ) . ')';
274             }
275         }
276
277         #
278         # Indices
279         #
280         for my $index ( $table->get_indices ) {
281             push @index_defs,
282                 'CREATE INDEX ' . $index->name .
283                 " ON $table_name (".
284                 join( ', ', $index->fields ) . ");";
285         }
286
287         my $create_statement;
288         $create_statement  = qq[DROP TABLE $table_name_ur;\n]
289             if $add_drop_table;
290         $create_statement .= qq[CREATE TABLE $table_name_ur (\n].
291             join( ",\n",
292                 map { "  $_" } @field_defs, @constraint_defs
293             ).
294             "\n);"
295         ;
296
297         $output .= join( "\n\n",
298             @comments,
299             $create_statement,
300             @index_defs,
301             ''
302         );
303     }
304
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();
325         push @comments,
326             "--\n-- Procedure: $procedure_name\n--" unless $no_comments;
327
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.
332
333         $output .= join("\n\n",
334                        @comments,
335                        $procedure->sql(),
336                        );
337     }
338
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
355 sub mk_name {
356     my $basename      = shift || '';
357     my $type          = shift || '';
358     my $scope         = shift || '';
359     my $critical      = shift || '';
360     my $basename_orig = $basename;
361     my $max_name      = $type
362                         ? $max_id_length - (length($type) + 1)
363                         : $max_id_length;
364     $basename         = substr( $basename, 0, $max_name )
365                         if length( $basename ) > $max_name;
366     my $name          = $type ? "${type}_$basename" : $basename;
367
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 );
379         substr($name, $max_id_length - 3) = "00"
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     }
387     $name = substr( $name, 0, $max_id_length )
388                         if ((length( $name ) > $max_id_length) && $critical);
389     $scope->{ $name }++;
390     return $name;
391 }
392
393 sub unreserve {
394     my $name            = shift || '';
395     my $schema_obj_name = shift || '';
396     my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
397
398     # also trap fields that don't begin with a letter
399     return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
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
412 1;
413
414 =pod
415
416 =head1 SEE ALSO
417
418 SQL::Translator.
419
420 =head1 AUTHORS
421
422 Sam Angiuoli E<lt>angiuoli@users.sourceforge.netE<gt>,
423 Paul Harrington E<lt>harringp@deshaw.comE<gt>,
424 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>.
425
426 =cut