1 package SQL::Translator::Producer::Sybase;
3 # -------------------------------------------------------------------
4 # $Id: Sybase.pm,v 1.6 2003-08-18 15:43:15 kycl4rk 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.6 $ =~ /(\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",
319 warn "Truncated " . keys( %truncated ) . " names:\n";
320 warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
324 warn "Encounted " . keys( %unreserve ) .
325 " unsafe names in schema (reserved or invalid):\n";
326 warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
333 # -------------------------------------------------------------------
335 my $basename = shift || '';
336 my $type = shift || '';
337 my $scope = shift || '';
338 my $critical = shift || '';
339 my $basename_orig = $basename;
341 ? $max_id_length - (length($type) + 1)
343 $basename = substr( $basename, 0, $max_name )
344 if length( $basename ) > $max_name;
345 my $name = $type ? "${type}_$basename" : $basename;
347 if ( $basename ne $basename_orig and $critical ) {
348 my $show_type = $type ? "+'$type'" : "";
349 warn "Truncating '$basename_orig'$show_type to $max_id_length ",
350 "character limit to make '$name'\n" if $WARN;
351 $truncated{ $basename_orig } = $name;
354 $scope ||= \%global_names;
355 if ( my $prev = $scope->{ $name } ) {
356 my $name_orig = $name;
357 $name .= sprintf( "%02d", ++$prev );
358 substr($name, $max_id_length - 3) = "00"
359 if length( $name ) > $max_id_length;
361 warn "The name '$name_orig' has been changed to ",
362 "'$name' to make it unique.\n" if $WARN;
364 $scope->{ $name_orig }++;
366 $name = substr( $name, 0, $max_id_length )
367 if ((length( $name ) > $max_id_length) && $critical);
372 # -------------------------------------------------------------------
374 my $name = shift || '';
375 my $schema_obj_name = shift || '';
376 my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
378 # also trap fields that don't begin with a letter
379 return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
381 if ( $schema_obj_name ) {
382 ++$unreserve{"$schema_obj_name.$name"};
385 ++$unreserve{"$name (table name)"};
388 my $unreserve = sprintf '%s_', $name;
389 return $unreserve.$suffix;
394 # -------------------------------------------------------------------
400 Sam Angiuoli E<lt>angiuoli@users.sourceforge.netE<gt>,
401 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>