1 package SQL::Translator::Producer::Sybase;
3 # -------------------------------------------------------------------
4 # $Id: Sybase.pm,v 1.4 2003-06-11 04:00:44 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.4 $ =~ /(\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 my $commalist = join ",", @$list;
177 if ( $data_type eq 'enum' ) {
178 my $check_name = mk_name(
179 $table_name.'_'.$field_name, 'chk' ,undef, 1
181 push @constraint_defs,
182 "CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
183 $data_type .= 'character varying';
185 elsif ( $data_type eq 'set' ) {
186 $data_type .= 'character varying';
188 elsif ( $field->is_auto_increment ) {
189 $field_def .= ' IDENTITY';
192 if ( defined $translate{ $data_type } ) {
193 $data_type = $translate{ $data_type };
196 warn "Unknown datatype: $data_type ",
197 "($table_name.$field_name)\n" if $WARN;
201 my $size = $field->size;
203 if ( $data_type =~ /numeric/ ) {
206 elsif ( $orig_data_type eq 'text' ) {
207 #interpret text fields as long varchars
211 $data_type eq 'varchar' &&
212 $orig_data_type eq 'boolean'
216 elsif ( $data_type eq 'varchar' ) {
221 $field_def .= " $data_type";
222 $field_def .= "($size)" if $size;
227 my $default = $field->default_value;
228 if ( defined $default ) {
229 $field_def .= sprintf( ' DEFAULT %s',
230 ( $field->is_auto_increment && $seq_name )
231 ? qq[nextval('"$seq_name"'::text)] :
232 ( $default =~ m/null/i ) ? 'NULL' : "'$default'"
237 # Not null constraint
239 unless ( $field->is_nullable ) {
240 $field_def .= ' NOT NULL';
243 $field_def .= ' NULL' if $data_type ne 'bit';
246 push @field_defs, $field_def;
250 # Constraint Declarations
252 my @constraint_decs = ();
254 for my $constraint ( $table->get_constraints ) {
255 my $name = $constraint->name || '';
256 my $type = $constraint->type || NORMAL;
257 my @fields = map { unreserve( $_, $table_name ) }
259 my @rfields = map { unreserve( $_, $table_name ) }
260 $constraint->reference_fields;
263 if ( $type eq PRIMARY_KEY ) {
264 $name ||= mk_name( $table_name, 'pk', undef,1 );
265 push @constraint_defs,
266 "CONSTRAINT $name PRIMARY KEY ".
267 '(' . join( ', ', @fields ) . ')';
269 elsif ( $type eq FOREIGN_KEY ) {
270 $name ||= mk_name( $table_name, 'fk', undef,1 );
271 push @constraint_defs,
272 "CONSTRAINT $name FOREIGN KEY".
273 ' (' . join( ', ', @fields ) . ') REFERENCES '.
274 $constraint->reference_table.
275 ' (' . join( ', ', @rfields ) . ')';
277 elsif ( $type eq UNIQUE ) {
280 $name || ++$c_name_default,undef, 1
282 push @constraint_defs,
283 "CONSTRAINT $name UNIQUE " .
284 '(' . join( ', ', @fields ) . ')';
291 for my $index ( $table->get_indices ) {
293 'CREATE INDEX ' . $index->name .
295 join( ', ', $index->fields ) . ");";
298 my $create_statement;
299 $create_statement = qq[DROP TABLE $table_name_ur;\n]
301 $create_statement .= qq[CREATE TABLE $table_name_ur (\n].
303 map { " $_" } @field_defs, @constraint_defs
308 $output .= join( "\n\n",
318 warn "Truncated " . keys( %truncated ) . " names:\n";
319 warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
323 warn "Encounted " . keys( %unreserve ) .
324 " unsafe names in schema (reserved or invalid):\n";
325 warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
332 # -------------------------------------------------------------------
334 my $basename = shift || '';
335 my $type = shift || '';
336 my $scope = shift || '';
337 my $critical = shift || '';
338 my $basename_orig = $basename;
340 ? $max_id_length - (length($type) + 1)
342 $basename = substr( $basename, 0, $max_name )
343 if length( $basename ) > $max_name;
344 my $name = $type ? "${type}_$basename" : $basename;
346 if ( $basename ne $basename_orig and $critical ) {
347 my $show_type = $type ? "+'$type'" : "";
348 warn "Truncating '$basename_orig'$show_type to $max_id_length ",
349 "character limit to make '$name'\n" if $WARN;
350 $truncated{ $basename_orig } = $name;
353 $scope ||= \%global_names;
354 if ( my $prev = $scope->{ $name } ) {
355 my $name_orig = $name;
356 $name .= sprintf( "%02d", ++$prev );
357 substr($name, $max_id_length - 3) = "00"
358 if length( $name ) > $max_id_length;
360 warn "The name '$name_orig' has been changed to ",
361 "'$name' to make it unique.\n" if $WARN;
363 $scope->{ $name_orig }++;
365 $name = substr( $name, 0, $max_id_length )
366 if ((length( $name ) > $max_id_length) && $critical);
371 # -------------------------------------------------------------------
373 my $name = shift || '';
374 my $schema_obj_name = shift || '';
375 my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
377 # also trap fields that don't begin with a letter
378 return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
380 if ( $schema_obj_name ) {
381 ++$unreserve{"$schema_obj_name.$name"};
384 ++$unreserve{"$name (table name)"};
387 my $unreserve = sprintf '%s_', $name;
388 return $unreserve.$suffix;
393 # -------------------------------------------------------------------
399 Sam Angiuoli E<lt>angiuoli@users.sourceforge.netE<gt>,
400 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>