1 package SQL::Translator::Producer::Sybase;
3 # -------------------------------------------------------------------
4 # $Id: Sybase.pm,v 1.7 2003-10-04 00:06:39 phrrngtn Exp $
5 # -------------------------------------------------------------------
6 # Copyright (C) 2003 Ken Y. Clark <kclark@cpan.org>,
7 # darren chamberlain <darren@cpan.org>,
8 # Chris Mungall <cjm@fruitfly.org>,
9 # Sam Angiuoli <angiuoli@users.sourceforge.net>
11 # This program is free software; you can redistribute it and/or
12 # modify it under the terms of the GNU General Public License as
13 # published by the Free Software Foundation; version 2.
15 # This program is distributed in the hope that it will be useful, but
16 # WITHOUT ANY WARRANTY; without even the implied warranty of
17 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 # General Public License for more details.
20 # You should have received a copy of the GNU General Public License
21 # along with this program; if not, write to the Free Software
22 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
24 # -------------------------------------------------------------------
28 SQL::Translator::Producer::Sybase - Sybase producer for SQL::Translator
33 use vars qw[ $DEBUG $WARN $VERSION ];
34 $VERSION = sprintf "%d.%02d", q$Revision: 1.7 $ =~ /(\d+)\.(\d+)/;
35 $DEBUG = 1 unless defined $DEBUG;
38 use SQL::Translator::Schema::Constants;
39 use SQL::Translator::Utils qw(debug header_comment);
50 varchar2 => 'varchar',
51 timestamp => 'datetime',
53 real => 'double precision',
56 tinyint => 'smallint',
57 float => 'double precision',
64 my %reserved = map { $_, 1 } qw[
65 ALL ANALYSE ANALYZE AND ANY AS ASC
67 CASE CAST CHECK COLLATE COLUMN CONSTRAINT CROSS
68 CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP CURRENT_USER
69 DEFAULT DEFERRABLE DESC DISTINCT DO
71 FALSE FOR FOREIGN FREEZE FROM FULL
73 ILIKE IN INITIALLY INNER INTERSECT INTO IS ISNULL
74 JOIN LEADING LEFT LIKE LIMIT
75 NATURAL NEW NOT NOTNULL NULL
76 OFF OFFSET OLD ON ONLY OR ORDER OUTER OVERLAPS
77 PRIMARY PUBLIC REFERENCES RIGHT
78 SELECT SESSION_USER SOME TABLE THEN TO TRAILING TRUE
79 UNION UNIQUE USER USING VERBOSE WHEN WHERE
82 my $max_id_length = 30;
83 my %used_identifiers = ();
90 =head1 Sybase Create Table Syntax
92 CREATE [ [ LOCAL ] { TEMPORARY | TEMP } ] TABLE table_name (
93 { column_name data_type [ DEFAULT default_expr ] [ column_constraint [, ... ] ]
94 | table_constraint } [, ... ]
96 [ INHERITS ( parent_table [, ... ] ) ]
97 [ WITH OIDS | WITHOUT OIDS ]
99 where column_constraint is:
101 [ CONSTRAINT constraint_name ]
102 { NOT NULL | NULL | UNIQUE | PRIMARY KEY |
104 REFERENCES reftable [ ( refcolumn ) ] [ MATCH FULL | MATCH PARTIAL ]
105 [ ON DELETE action ] [ ON UPDATE action ] }
106 [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
108 and table_constraint is:
110 [ CONSTRAINT constraint_name ]
111 { UNIQUE ( column_name [, ... ] ) |
112 PRIMARY KEY ( column_name [, ... ] ) |
113 CHECK ( expression ) |
114 FOREIGN KEY ( column_name [, ... ] ) REFERENCES reftable [ ( refcolumn [, ... ] ) ]
115 [ MATCH FULL | MATCH PARTIAL ] [ ON DELETE action ] [ ON UPDATE action ] }
116 [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
118 =head1 Create Index Syntax
120 CREATE [ UNIQUE ] INDEX index_name ON table
121 [ USING acc_method ] ( column [ ops_name ] [, ...] )
123 CREATE [ UNIQUE ] INDEX index_name ON table
124 [ USING acc_method ] ( func_name( column [, ... ]) [ ops_name ] )
129 # -------------------------------------------------------------------
131 my $translator = shift;
132 $DEBUG = $translator->debug;
133 $WARN = $translator->show_warnings;
134 my $no_comments = $translator->no_comments;
135 my $add_drop_table = $translator->add_drop_table;
136 my $schema = $translator->schema;
139 $output .= header_comment unless ($no_comments);
141 for my $table ( $schema->get_tables ) {
142 my $table_name = $table->name or next;
143 $table_name = mk_name( $table_name, '', undef, 1 );
144 my $table_name_ur = unreserve($table_name) || '';
146 my ( @comments, @field_defs, @index_defs, @constraint_defs );
148 push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;
150 push @comments, map { "-- $_" } $table->comments;
155 my %field_name_scope;
156 for my $field ( $table->get_fields ) {
157 my $field_name = mk_name(
158 $field->name, '', \%field_name_scope, undef,1
160 my $field_name_ur = unreserve( $field_name, $table_name );
161 my $field_def = qq["$field_name_ur"];
162 $field_def =~ s/\"//g;
163 if ( $field_def =~ /identity/ ){
164 $field_def =~ s/identity/pidentity/;
170 my $data_type = lc $field->data_type;
171 my $orig_data_type = $data_type;
172 my %extra = $field->extra;
173 my $list = $extra{'list'} || [];
174 # \todo deal with embedded quotes
175 my $commalist = join( ', ', map { qq['$_'] } @$list );
178 if ( $data_type eq 'enum' ) {
179 my $check_name = mk_name(
180 $table_name.'_'.$field_name, 'chk' ,undef, 1
182 push @constraint_defs,
183 "CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
184 $data_type .= 'character varying';
186 elsif ( $data_type eq 'set' ) {
187 $data_type .= 'character varying';
189 elsif ( $field->is_auto_increment ) {
190 $field_def .= ' IDENTITY';
193 if ( defined $translate{ $data_type } ) {
194 $data_type = $translate{ $data_type };
197 warn "Unknown datatype: $data_type ",
198 "($table_name.$field_name)\n" if $WARN;
202 my $size = $field->size;
204 if ( $data_type =~ /numeric/ ) {
207 elsif ( $orig_data_type eq 'text' ) {
208 #interpret text fields as long varchars
212 $data_type eq 'varchar' &&
213 $orig_data_type eq 'boolean'
217 elsif ( $data_type eq 'varchar' ) {
222 $field_def .= " $data_type";
223 $field_def .= "($size)" if $size;
228 my $default = $field->default_value;
229 if ( defined $default ) {
230 $field_def .= sprintf( ' DEFAULT %s',
231 ( $field->is_auto_increment && $seq_name )
232 ? qq[nextval('"$seq_name"'::text)] :
233 ( $default =~ m/null/i ) ? 'NULL' : "'$default'"
238 # Not null constraint
240 unless ( $field->is_nullable ) {
241 $field_def .= ' NOT NULL';
244 $field_def .= ' NULL' if $data_type ne 'bit';
247 push @field_defs, $field_def;
251 # Constraint Declarations
253 my @constraint_decs = ();
255 for my $constraint ( $table->get_constraints ) {
256 my $name = $constraint->name || '';
257 my $type = $constraint->type || NORMAL;
258 my @fields = map { unreserve( $_, $table_name ) }
260 my @rfields = map { unreserve( $_, $table_name ) }
261 $constraint->reference_fields;
264 if ( $type eq PRIMARY_KEY ) {
265 $name ||= mk_name( $table_name, 'pk', undef,1 );
266 push @constraint_defs,
267 "CONSTRAINT $name PRIMARY KEY ".
268 '(' . join( ', ', @fields ) . ')';
270 elsif ( $type eq FOREIGN_KEY ) {
271 $name ||= mk_name( $table_name, 'fk', undef,1 );
272 push @constraint_defs,
273 "CONSTRAINT $name FOREIGN KEY".
274 ' (' . join( ', ', @fields ) . ') REFERENCES '.
275 $constraint->reference_table.
276 ' (' . join( ', ', @rfields ) . ')';
278 elsif ( $type eq UNIQUE ) {
281 $name || ++$c_name_default,undef, 1
283 push @constraint_defs,
284 "CONSTRAINT $name UNIQUE " .
285 '(' . join( ', ', @fields ) . ')';
292 for my $index ( $table->get_indices ) {
294 'CREATE INDEX ' . $index->name .
296 join( ', ', $index->fields ) . ");";
299 my $create_statement;
300 $create_statement = qq[DROP TABLE $table_name_ur;\n]
302 $create_statement .= qq[CREATE TABLE $table_name_ur (\n].
304 map { " $_" } @field_defs, @constraint_defs
309 $output .= join( "\n\n",
317 foreach my $view ( $schema->get_views ) {
318 my (@comments, $view_name);
320 $view_name = $view->name();
321 push @comments, "--\n-- View: $view_name\n--" unless $no_comments;
323 # text of view is already a 'create view' statement so no need
324 # to do anything fancy.
326 $output .= join("\n\n",
333 foreach my $procedure ( $schema->get_procedures ) {
334 my (@comments, $procedure_name);
336 $procedure_name = $procedure->name();
337 push @comments, "--\n-- Procedure: $procedure_name\n--" unless $no_comments;
339 # text of procedure already has the 'create procedure' stuff so there
340 # is no need to do anything fancy. However, we should think about doing fancy stuff
341 # with granting permissions and so on.
343 $output .= join("\n\n",
351 warn "Truncated " . keys( %truncated ) . " names:\n";
352 warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
356 warn "Encounted " . keys( %unreserve ) .
357 " unsafe names in schema (reserved or invalid):\n";
358 warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
365 # -------------------------------------------------------------------
367 my $basename = shift || '';
368 my $type = shift || '';
369 my $scope = shift || '';
370 my $critical = shift || '';
371 my $basename_orig = $basename;
373 ? $max_id_length - (length($type) + 1)
375 $basename = substr( $basename, 0, $max_name )
376 if length( $basename ) > $max_name;
377 my $name = $type ? "${type}_$basename" : $basename;
379 if ( $basename ne $basename_orig and $critical ) {
380 my $show_type = $type ? "+'$type'" : "";
381 warn "Truncating '$basename_orig'$show_type to $max_id_length ",
382 "character limit to make '$name'\n" if $WARN;
383 $truncated{ $basename_orig } = $name;
386 $scope ||= \%global_names;
387 if ( my $prev = $scope->{ $name } ) {
388 my $name_orig = $name;
389 $name .= sprintf( "%02d", ++$prev );
390 substr($name, $max_id_length - 3) = "00"
391 if length( $name ) > $max_id_length;
393 warn "The name '$name_orig' has been changed to ",
394 "'$name' to make it unique.\n" if $WARN;
396 $scope->{ $name_orig }++;
398 $name = substr( $name, 0, $max_id_length )
399 if ((length( $name ) > $max_id_length) && $critical);
404 # -------------------------------------------------------------------
406 my $name = shift || '';
407 my $schema_obj_name = shift || '';
408 my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
410 # also trap fields that don't begin with a letter
411 return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
413 if ( $schema_obj_name ) {
414 ++$unreserve{"$schema_obj_name.$name"};
417 ++$unreserve{"$name (table name)"};
420 my $unreserve = sprintf '%s_', $name;
421 return $unreserve.$suffix;
426 # -------------------------------------------------------------------
432 Sam Angiuoli E<lt>angiuoli@users.sourceforge.netE<gt>,
433 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>