1 package SQL::Translator::Producer::Sybase;
3 # -------------------------------------------------------------------
5 # -------------------------------------------------------------------
6 # Copyright (C) 2002-2009 SQLFairy Authors
8 # This program is free software; you can redistribute it and/or
9 # modify it under the terms of the GNU General Public License as
10 # published by the Free Software Foundation; version 2.
12 # This program is distributed in the hope that it will be useful, but
13 # WITHOUT ANY WARRANTY; without even the implied warranty of
14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
15 # General Public License for more details.
17 # You should have received a copy of the GNU General Public License
18 # along with this program; if not, write to the Free Software
19 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
21 # -------------------------------------------------------------------
25 SQL::Translator::Producer::Sybase - Sybase producer for SQL::Translator
31 my $t = SQL::Translator->new( parser => '...', producer => 'Sybase' );
36 This module will produce text output of the schema suitable for Sybase.
41 use vars qw[ $DEBUG $WARN ];
42 $DEBUG = 1 unless defined $DEBUG;
45 use SQL::Translator::Schema::Constants;
46 use SQL::Translator::Utils qw(debug header_comment);
57 varchar2 => 'varchar',
58 timestamp => 'datetime',
60 real => 'double precision',
63 tinyint => 'smallint',
64 float => 'double precision',
71 my %reserved = map { $_, 1 } qw[
72 ALL ANALYSE ANALYZE AND ANY AS ASC
74 CASE CAST CHECK COLLATE COLUMN CONSTRAINT CROSS
75 CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP CURRENT_USER
76 DEFAULT DEFERRABLE DESC DISTINCT DO
78 FALSE FOR FOREIGN FREEZE FROM FULL
80 ILIKE IN INITIALLY INNER INTERSECT INTO IS ISNULL
81 JOIN LEADING LEFT LIKE LIMIT
82 NATURAL NEW NOT NOTNULL NULL
83 OFF OFFSET OLD ON ONLY OR ORDER OUTER OVERLAPS
84 PRIMARY PUBLIC REFERENCES RIGHT
85 SELECT SESSION_USER SOME TABLE THEN TO TRAILING TRUE
86 UNION UNIQUE USER USING VERBOSE WHEN WHERE
89 my $max_id_length = 30;
90 my %used_identifiers = ();
97 =head1 Sybase Create Table Syntax
99 CREATE [ [ LOCAL ] { TEMPORARY | TEMP } ] TABLE table_name (
100 { column_name data_type [ DEFAULT default_expr ] [ column_constraint [, ... ] ]
101 | table_constraint } [, ... ]
103 [ INHERITS ( parent_table [, ... ] ) ]
104 [ WITH OIDS | WITHOUT OIDS ]
106 where column_constraint is:
108 [ CONSTRAINT constraint_name ]
109 { NOT NULL | NULL | UNIQUE | PRIMARY KEY |
111 REFERENCES reftable [ ( refcolumn ) ] [ MATCH FULL | MATCH PARTIAL ]
112 [ ON DELETE action ] [ ON UPDATE action ] }
113 [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
115 and table_constraint is:
117 [ CONSTRAINT constraint_name ]
118 { UNIQUE ( column_name [, ... ] ) |
119 PRIMARY KEY ( column_name [, ... ] ) |
120 CHECK ( expression ) |
121 FOREIGN KEY ( column_name [, ... ] ) REFERENCES reftable [ ( refcolumn [, ... ] ) ]
122 [ MATCH FULL | MATCH PARTIAL ] [ ON DELETE action ] [ ON UPDATE action ] }
123 [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
125 =head1 Create Index Syntax
127 CREATE [ UNIQUE ] INDEX index_name ON table
128 [ USING acc_method ] ( column [ ops_name ] [, ...] )
130 CREATE [ UNIQUE ] INDEX index_name ON table
131 [ USING acc_method ] ( func_name( column [, ... ]) [ ops_name ] )
136 # -------------------------------------------------------------------
138 my $translator = shift;
139 $DEBUG = $translator->debug;
140 $WARN = $translator->show_warnings;
141 my $no_comments = $translator->no_comments;
142 my $add_drop_table = $translator->add_drop_table;
143 my $schema = $translator->schema;
146 $output .= header_comment unless ($no_comments);
148 for my $table ( $schema->get_tables ) {
149 my $table_name = $table->name or next;
150 $table_name = mk_name( $table_name, '', undef, 1 );
151 my $table_name_ur = unreserve($table_name) || '';
153 my ( @comments, @field_defs, @index_defs, @constraint_defs );
155 push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;
157 push @comments, map { "-- $_" } $table->comments;
162 my %field_name_scope;
163 for my $field ( $table->get_fields ) {
164 my $field_name = mk_name(
165 $field->name, '', \%field_name_scope, undef,1
167 my $field_name_ur = unreserve( $field_name, $table_name );
168 my $field_def = qq["$field_name_ur"];
169 $field_def =~ s/\"//g;
170 if ( $field_def =~ /identity/ ){
171 $field_def =~ s/identity/pidentity/;
177 my $data_type = lc $field->data_type;
178 my $orig_data_type = $data_type;
179 my %extra = $field->extra;
180 my $list = $extra{'list'} || [];
181 # \todo deal with embedded quotes
182 my $commalist = join( ', ', map { qq['$_'] } @$list );
185 if ( $data_type eq 'enum' ) {
186 my $check_name = mk_name(
187 $table_name.'_'.$field_name, 'chk' ,undef, 1
189 push @constraint_defs,
190 "CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
191 $data_type .= 'character varying';
193 elsif ( $data_type eq 'set' ) {
194 $data_type .= 'character varying';
196 elsif ( $field->is_auto_increment ) {
197 $field_def .= ' IDENTITY';
200 if ( defined $translate{ $data_type } ) {
201 $data_type = $translate{ $data_type };
204 warn "Unknown datatype: $data_type ",
205 "($table_name.$field_name)\n" if $WARN;
209 my $size = $field->size;
211 if ( $data_type =~ /numeric/ ) {
214 elsif ( $orig_data_type eq 'text' ) {
215 #interpret text fields as long varchars
219 $data_type eq 'varchar' &&
220 $orig_data_type eq 'boolean'
224 elsif ( $data_type eq 'varchar' ) {
229 $field_def .= " $data_type";
230 $field_def .= "($size)" if $size;
235 my $default = $field->default_value;
236 if ( defined $default ) {
237 $field_def .= sprintf( ' DEFAULT %s',
238 ( $field->is_auto_increment && $seq_name )
239 ? qq[nextval('"$seq_name"'::text)] :
240 ( $default =~ m/null/i ) ? 'NULL' : "'$default'"
245 # Not null constraint
247 unless ( $field->is_nullable ) {
248 $field_def .= ' NOT NULL';
251 $field_def .= ' NULL' if $data_type ne 'bit';
254 push @field_defs, $field_def;
258 # Constraint Declarations
260 my @constraint_decs = ();
262 for my $constraint ( $table->get_constraints ) {
263 my $name = $constraint->name || '';
264 my $type = $constraint->type || NORMAL;
265 my @fields = map { unreserve( $_, $table_name ) }
267 my @rfields = map { unreserve( $_, $table_name ) }
268 $constraint->reference_fields;
271 if ( $type eq PRIMARY_KEY ) {
272 $name ||= mk_name( $table_name, 'pk', undef,1 );
273 push @constraint_defs,
274 "CONSTRAINT $name PRIMARY KEY ".
275 '(' . join( ', ', @fields ) . ')';
277 elsif ( $type eq FOREIGN_KEY ) {
278 $name ||= mk_name( $table_name, 'fk', undef,1 );
279 push @constraint_defs,
280 "CONSTRAINT $name FOREIGN KEY".
281 ' (' . join( ', ', @fields ) . ') REFERENCES '.
282 $constraint->reference_table.
283 ' (' . join( ', ', @rfields ) . ')';
285 elsif ( $type eq UNIQUE ) {
288 $name || ++$c_name_default,undef, 1
290 push @constraint_defs,
291 "CONSTRAINT $name UNIQUE " .
292 '(' . join( ', ', @fields ) . ')';
299 for my $index ( $table->get_indices ) {
301 'CREATE INDEX ' . $index->name .
303 join( ', ', $index->fields ) . ");";
306 my $create_statement;
307 $create_statement = qq[DROP TABLE $table_name_ur;\n]
309 $create_statement .= qq[CREATE TABLE $table_name_ur (\n].
311 map { " $_" } @field_defs, @constraint_defs
316 $output .= join( "\n\n",
324 foreach my $view ( $schema->get_views ) {
325 my (@comments, $view_name);
327 $view_name = $view->name();
328 push @comments, "--\n-- View: $view_name\n--" unless $no_comments;
330 # text of view is already a 'create view' statement so no need
331 # to do anything fancy.
333 $output .= join("\n\n",
340 foreach my $procedure ( $schema->get_procedures ) {
341 my (@comments, $procedure_name);
343 $procedure_name = $procedure->name();
345 "--\n-- Procedure: $procedure_name\n--" unless $no_comments;
347 # text of procedure already has the 'create procedure' stuff
348 # so there is no need to do anything fancy. However, we should
349 # think about doing fancy stuff with granting permissions and
352 $output .= join("\n\n",
360 warn "Truncated " . keys( %truncated ) . " names:\n";
361 warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
365 warn "Encounted " . keys( %unreserve ) .
366 " unsafe names in schema (reserved or invalid):\n";
367 warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
374 # -------------------------------------------------------------------
376 my $basename = shift || '';
377 my $type = shift || '';
378 my $scope = shift || '';
379 my $critical = shift || '';
380 my $basename_orig = $basename;
382 ? $max_id_length - (length($type) + 1)
384 $basename = substr( $basename, 0, $max_name )
385 if length( $basename ) > $max_name;
386 my $name = $type ? "${type}_$basename" : $basename;
388 if ( $basename ne $basename_orig and $critical ) {
389 my $show_type = $type ? "+'$type'" : "";
390 warn "Truncating '$basename_orig'$show_type to $max_id_length ",
391 "character limit to make '$name'\n" if $WARN;
392 $truncated{ $basename_orig } = $name;
395 $scope ||= \%global_names;
396 if ( my $prev = $scope->{ $name } ) {
397 my $name_orig = $name;
398 $name .= sprintf( "%02d", ++$prev );
399 substr($name, $max_id_length - 3) = "00"
400 if length( $name ) > $max_id_length;
402 warn "The name '$name_orig' has been changed to ",
403 "'$name' to make it unique.\n" if $WARN;
405 $scope->{ $name_orig }++;
407 $name = substr( $name, 0, $max_id_length )
408 if ((length( $name ) > $max_id_length) && $critical);
413 # -------------------------------------------------------------------
415 my $name = shift || '';
416 my $schema_obj_name = shift || '';
417 my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
419 # also trap fields that don't begin with a letter
420 return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
422 if ( $schema_obj_name ) {
423 ++$unreserve{"$schema_obj_name.$name"};
426 ++$unreserve{"$name (table name)"};
429 my $unreserve = sprintf '%s_', $name;
430 return $unreserve.$suffix;
435 # -------------------------------------------------------------------
445 Sam Angiuoli E<lt>angiuoli@users.sourceforge.netE<gt>,
446 Paul Harrington E<lt>harringp@deshaw.comE<gt>,
447 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.