1 package SQL::Translator::Producer::Sybase;
3 # -------------------------------------------------------------------
4 # Copyright (C) 2002-2009 SQLFairy Authors
6 # This program is free software; you can redistribute it and/or
7 # modify it under the terms of the GNU General Public License as
8 # published by the Free Software Foundation; version 2.
10 # This program is distributed in the hope that it will be useful, but
11 # WITHOUT ANY WARRANTY; without even the implied warranty of
12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 # General Public License for more details.
15 # You should have received a copy of the GNU General Public License
16 # along with this program; if not, write to the Free Software
17 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
19 # -------------------------------------------------------------------
23 SQL::Translator::Producer::Sybase - Sybase producer for SQL::Translator
29 my $t = SQL::Translator->new( parser => '...', producer => 'Sybase' );
34 This module will produce text output of the schema suitable for Sybase.
39 use vars qw[ $DEBUG $WARN $VERSION ];
41 $DEBUG = 1 unless defined $DEBUG;
44 use SQL::Translator::Schema::Constants;
45 use SQL::Translator::Utils qw(debug header_comment);
56 varchar2 => 'varchar',
57 timestamp => 'datetime',
59 real => 'double precision',
62 tinyint => 'smallint',
63 float => 'double precision',
70 my %reserved = map { $_, 1 } qw[
71 ALL ANALYSE ANALYZE AND ANY AS ASC
73 CASE CAST CHECK COLLATE COLUMN CONSTRAINT CROSS
74 CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP CURRENT_USER
75 DEFAULT DEFERRABLE DESC DISTINCT DO
77 FALSE FOR FOREIGN FREEZE FROM FULL
79 ILIKE IN INITIALLY INNER INTERSECT INTO IS ISNULL
80 JOIN LEADING LEFT LIKE LIMIT
81 NATURAL NEW NOT NOTNULL NULL
82 OFF OFFSET OLD ON ONLY OR ORDER OUTER OVERLAPS
83 PRIMARY PUBLIC REFERENCES RIGHT
84 SELECT SESSION_USER SOME TABLE THEN TO TRAILING TRUE
85 UNION UNIQUE USER USING VERBOSE WHEN WHERE
88 my $max_id_length = 30;
89 my %used_identifiers = ();
96 =head1 Sybase Create Table Syntax
98 CREATE [ [ LOCAL ] { TEMPORARY | TEMP } ] TABLE table_name (
99 { column_name data_type [ DEFAULT default_expr ] [ column_constraint [, ... ] ]
100 | table_constraint } [, ... ]
102 [ INHERITS ( parent_table [, ... ] ) ]
103 [ WITH OIDS | WITHOUT OIDS ]
105 where column_constraint is:
107 [ CONSTRAINT constraint_name ]
108 { NOT NULL | NULL | UNIQUE | PRIMARY KEY |
110 REFERENCES reftable [ ( refcolumn ) ] [ MATCH FULL | MATCH PARTIAL ]
111 [ ON DELETE action ] [ ON UPDATE action ] }
112 [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
114 and table_constraint is:
116 [ CONSTRAINT constraint_name ]
117 { UNIQUE ( column_name [, ... ] ) |
118 PRIMARY KEY ( column_name [, ... ] ) |
119 CHECK ( expression ) |
120 FOREIGN KEY ( column_name [, ... ] ) REFERENCES reftable [ ( refcolumn [, ... ] ) ]
121 [ MATCH FULL | MATCH PARTIAL ] [ ON DELETE action ] [ ON UPDATE action ] }
122 [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
124 =head1 Create Index Syntax
126 CREATE [ UNIQUE ] INDEX index_name ON table
127 [ USING acc_method ] ( column [ ops_name ] [, ...] )
129 CREATE [ UNIQUE ] INDEX index_name ON table
130 [ USING acc_method ] ( func_name( column [, ... ]) [ ops_name ] )
135 # -------------------------------------------------------------------
137 my $translator = shift;
138 $DEBUG = $translator->debug;
139 $WARN = $translator->show_warnings;
140 my $no_comments = $translator->no_comments;
141 my $add_drop_table = $translator->add_drop_table;
142 my $schema = $translator->schema;
145 $output .= header_comment unless ($no_comments);
147 for my $table ( $schema->get_tables ) {
148 my $table_name = $table->name or next;
149 $table_name = mk_name( $table_name, '', undef, 1 );
150 my $table_name_ur = unreserve($table_name) || '';
152 my ( @comments, @field_defs, @index_defs, @constraint_defs );
154 push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;
156 push @comments, map { "-- $_" } $table->comments;
161 my %field_name_scope;
162 for my $field ( $table->get_fields ) {
163 my $field_name = mk_name(
164 $field->name, '', \%field_name_scope, undef,1
166 my $field_name_ur = unreserve( $field_name, $table_name );
167 my $field_def = qq["$field_name_ur"];
168 $field_def =~ s/\"//g;
169 if ( $field_def =~ /identity/ ){
170 $field_def =~ s/identity/pidentity/;
176 my $data_type = lc $field->data_type;
177 my $orig_data_type = $data_type;
178 my %extra = $field->extra;
179 my $list = $extra{'list'} || [];
180 # \todo deal with embedded quotes
181 my $commalist = join( ', ', map { qq['$_'] } @$list );
184 if ( $data_type eq 'enum' ) {
185 my $check_name = mk_name(
186 $table_name.'_'.$field_name, 'chk' ,undef, 1
188 push @constraint_defs,
189 "CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
190 $data_type .= 'character varying';
192 elsif ( $data_type eq 'set' ) {
193 $data_type .= 'character varying';
195 elsif ( $field->is_auto_increment ) {
196 $field_def .= ' IDENTITY';
199 if ( defined $translate{ $data_type } ) {
200 $data_type = $translate{ $data_type };
203 warn "Unknown datatype: $data_type ",
204 "($table_name.$field_name)\n" if $WARN;
208 my $size = $field->size;
210 if ( $data_type =~ /numeric/ ) {
213 elsif ( $orig_data_type eq 'text' ) {
214 #interpret text fields as long varchars
218 $data_type eq 'varchar' &&
219 $orig_data_type eq 'boolean'
223 elsif ( $data_type eq 'varchar' ) {
228 $field_def .= " $data_type";
229 $field_def .= "($size)" if $size;
234 my $default = $field->default_value;
235 if ( defined $default ) {
236 $field_def .= sprintf( ' DEFAULT %s',
237 ( $field->is_auto_increment && $seq_name )
238 ? qq[nextval('"$seq_name"'::text)] :
239 ( $default =~ m/null/i ) ? 'NULL' : "'$default'"
244 # Not null constraint
246 unless ( $field->is_nullable ) {
247 $field_def .= ' NOT NULL';
250 $field_def .= ' NULL' if $data_type ne 'bit';
253 push @field_defs, $field_def;
257 # Constraint Declarations
259 my @constraint_decs = ();
261 for my $constraint ( $table->get_constraints ) {
262 my $name = $constraint->name || '';
263 my $type = $constraint->type || NORMAL;
264 my @fields = map { unreserve( $_, $table_name ) }
266 my @rfields = map { unreserve( $_, $table_name ) }
267 $constraint->reference_fields;
270 if ( $type eq PRIMARY_KEY ) {
271 $name ||= mk_name( $table_name, 'pk', undef,1 );
272 push @constraint_defs,
273 "CONSTRAINT $name PRIMARY KEY ".
274 '(' . join( ', ', @fields ) . ')';
276 elsif ( $type eq FOREIGN_KEY ) {
277 $name ||= mk_name( $table_name, 'fk', undef,1 );
278 push @constraint_defs,
279 "CONSTRAINT $name FOREIGN KEY".
280 ' (' . join( ', ', @fields ) . ') REFERENCES '.
281 $constraint->reference_table.
282 ' (' . join( ', ', @rfields ) . ')';
284 elsif ( $type eq UNIQUE ) {
287 $name || ++$c_name_default,undef, 1
289 push @constraint_defs,
290 "CONSTRAINT $name UNIQUE " .
291 '(' . join( ', ', @fields ) . ')';
298 for my $index ( $table->get_indices ) {
300 'CREATE INDEX ' . $index->name .
302 join( ', ', $index->fields ) . ");";
305 my $create_statement;
306 $create_statement = qq[DROP TABLE $table_name_ur;\n]
308 $create_statement .= qq[CREATE TABLE $table_name_ur (\n].
310 map { " $_" } @field_defs, @constraint_defs
315 $output .= join( "\n\n",
323 foreach my $view ( $schema->get_views ) {
324 my (@comments, $view_name);
326 $view_name = $view->name();
327 push @comments, "--\n-- View: $view_name\n--" unless $no_comments;
329 # text of view is already a 'create view' statement so no need
330 # to do anything fancy.
332 $output .= join("\n\n",
339 foreach my $procedure ( $schema->get_procedures ) {
340 my (@comments, $procedure_name);
342 $procedure_name = $procedure->name();
344 "--\n-- Procedure: $procedure_name\n--" unless $no_comments;
346 # text of procedure already has the 'create procedure' stuff
347 # so there is no need to do anything fancy. However, we should
348 # think about doing fancy stuff with granting permissions and
351 $output .= join("\n\n",
359 warn "Truncated " . keys( %truncated ) . " names:\n";
360 warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
364 warn "Encounted " . keys( %unreserve ) .
365 " unsafe names in schema (reserved or invalid):\n";
366 warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
373 # -------------------------------------------------------------------
375 my $basename = shift || '';
376 my $type = shift || '';
377 my $scope = shift || '';
378 my $critical = shift || '';
379 my $basename_orig = $basename;
381 ? $max_id_length - (length($type) + 1)
383 $basename = substr( $basename, 0, $max_name )
384 if length( $basename ) > $max_name;
385 my $name = $type ? "${type}_$basename" : $basename;
387 if ( $basename ne $basename_orig and $critical ) {
388 my $show_type = $type ? "+'$type'" : "";
389 warn "Truncating '$basename_orig'$show_type to $max_id_length ",
390 "character limit to make '$name'\n" if $WARN;
391 $truncated{ $basename_orig } = $name;
394 $scope ||= \%global_names;
395 if ( my $prev = $scope->{ $name } ) {
396 my $name_orig = $name;
397 $name .= sprintf( "%02d", ++$prev );
398 substr($name, $max_id_length - 3) = "00"
399 if length( $name ) > $max_id_length;
401 warn "The name '$name_orig' has been changed to ",
402 "'$name' to make it unique.\n" if $WARN;
404 $scope->{ $name_orig }++;
406 $name = substr( $name, 0, $max_id_length )
407 if ((length( $name ) > $max_id_length) && $critical);
412 # -------------------------------------------------------------------
414 my $name = shift || '';
415 my $schema_obj_name = shift || '';
416 my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
418 # also trap fields that don't begin with a letter
419 return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
421 if ( $schema_obj_name ) {
422 ++$unreserve{"$schema_obj_name.$name"};
425 ++$unreserve{"$name (table name)"};
428 my $unreserve = sprintf '%s_', $name;
429 return $unreserve.$suffix;
434 # -------------------------------------------------------------------
444 Sam Angiuoli E<lt>angiuoli@users.sourceforge.netE<gt>,
445 Paul Harrington E<lt>harringp@deshaw.comE<gt>,
446 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>.