1 package SQL::Translator::Producer::Sybase;
3 # -------------------------------------------------------------------
4 # $Id: Sybase.pm,v 1.2 2003-05-12 15:00:34 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.2 $ =~ /(\d+)\.(\d+)/;
35 $DEBUG = 1 unless defined $DEBUG;
38 use SQL::Translator::Utils qw(debug header_comment);
47 timestamp => 'datetime',
49 real => 'double precision',
52 tinyint => 'smallint',
53 float => 'double precision',
60 my %reserved = map { $_, 1 } qw[
61 ALL ANALYSE ANALYZE AND ANY AS ASC
63 CASE CAST CHECK COLLATE COLUMN CONSTRAINT CROSS
64 CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP CURRENT_USER
65 DEFAULT DEFERRABLE DESC DISTINCT DO
67 FALSE FOR FOREIGN FREEZE FROM FULL
69 ILIKE IN INITIALLY INNER INTERSECT INTO IS ISNULL
70 JOIN LEADING LEFT LIKE LIMIT
71 NATURAL NEW NOT NOTNULL NULL
72 OFF OFFSET OLD ON ONLY OR ORDER OUTER OVERLAPS
73 PRIMARY PUBLIC REFERENCES RIGHT
74 SELECT SESSION_USER SOME TABLE THEN TO TRAILING TRUE
75 UNION UNIQUE USER USING VERBOSE WHEN WHERE
78 my $max_id_length = 30;
79 my %used_identifiers = ();
86 =head1 Sybase Create Table Syntax
88 CREATE [ [ LOCAL ] { TEMPORARY | TEMP } ] TABLE table_name (
89 { column_name data_type [ DEFAULT default_expr ] [ column_constraint [, ... ] ]
90 | table_constraint } [, ... ]
92 [ INHERITS ( parent_table [, ... ] ) ]
93 [ WITH OIDS | WITHOUT OIDS ]
95 where column_constraint is:
97 [ CONSTRAINT constraint_name ]
98 { NOT NULL | NULL | UNIQUE | PRIMARY KEY |
100 REFERENCES reftable [ ( refcolumn ) ] [ MATCH FULL | MATCH PARTIAL ]
101 [ ON DELETE action ] [ ON UPDATE action ] }
102 [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
104 and table_constraint is:
106 [ CONSTRAINT constraint_name ]
107 { UNIQUE ( column_name [, ... ] ) |
108 PRIMARY KEY ( column_name [, ... ] ) |
109 CHECK ( expression ) |
110 FOREIGN KEY ( column_name [, ... ] ) REFERENCES reftable [ ( refcolumn [, ... ] ) ]
111 [ MATCH FULL | MATCH PARTIAL ] [ ON DELETE action ] [ ON UPDATE action ] }
112 [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
114 =head1 Create Index Syntax
116 CREATE [ UNIQUE ] INDEX index_name ON table
117 [ USING acc_method ] ( column [ ops_name ] [, ...] )
119 CREATE [ UNIQUE ] INDEX index_name ON table
120 [ USING acc_method ] ( func_name( column [, ... ]) [ ops_name ] )
125 # -------------------------------------------------------------------
127 my ( $translator, $data ) = @_;
128 $DEBUG = $translator->debug;
129 $WARN = $translator->show_warnings;
130 my $no_comments = $translator->no_comments;
131 my $add_drop_table = $translator->add_drop_table;
134 $output .= header_comment unless ($no_comments);
138 sort { $a->[0] <=> $b->[0] }
139 map { [ $_->{'order'}, $_ ] }
142 my $table_name = $table->{'table_name'};
143 $table_name = mk_name( $table_name, '', undef, 1 );
144 my $table_name_ur = unreserve($table_name);
146 my ( @comments, @field_decs, @sequence_decs, @constraints );
148 push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;
153 my %field_name_scope;
156 sort { $a->[0] <=> $b->[0] }
157 map { [ $_->{'order'}, $_ ] }
158 values %{ $table->{'fields'} }
160 my $field_name = mk_name(
161 $field->{'name'}, '', \%field_name_scope, undef,1
163 my $field_name_ur = unreserve( $field_name, $table_name );
164 my $field_str = qq["$field_name_ur"];
165 $field_str =~ s/\"//g;
166 if ($field_str =~ /identity/){
167 $field_str =~ s/identity/pidentity/;
173 my $data_type = lc $field->{'data_type'};
174 my $orig_data_type = $data_type;
175 my $list = $field->{'list'} || [];
176 my $commalist = join ",", @$list;
179 if ( $data_type eq 'enum' ) {
181 $len = ($len < length($_)) ? length($_) : $len for (@$list);
182 my $check_name = mk_name(
183 $table_name.'_'.$field_name, 'chk' ,undef, 1
186 "CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
187 $field_str .= " character varying($len)";
189 elsif ( $data_type eq 'set' ) {
190 # XXX add a CHECK constraint maybe
191 # (trickier and slower, than enum :)
192 my $len = length $commalist;
193 $field_str .= " character varying($len) /* set $commalist */";
195 elsif ( $field->{'is_auto_inc'} ) {
196 $field_str .= ' IDENTITY';
199 $data_type = defined $translate{ $data_type } ?
200 $translate{ $data_type } :
201 die "Unknown datatype: $data_type\n";
202 $field_str .= ' '.$data_type;
203 if ( $data_type =~ /(char|varbit|decimal)/i ) {
204 $field_str .= '('.join(',', @{ $field->{'size'} }).')'
205 if @{ $field->{'size'} || [] };
207 elsif( $data_type =~ /numeric/){
208 $field_str .= '(9,0)';
211 if( $orig_data_type eq 'text'){
212 #interpret text fields as long varchars
213 $field_str .= '(255)';
215 elsif($data_type eq "varchar" && $orig_data_type eq "boolean"){
218 elsif($data_type eq "varchar" && (!$field->{'size'})){
219 $field_str .= '(255)';
227 if ( defined $field->{'default'} ) {
228 $field_str .= sprintf( ' DEFAULT %s',
229 ( $field->{'is_auto_inc'} && $seq_name )
230 ? qq[nextval('"$seq_name"'::text)] :
231 ( $field->{'default'} =~ m/null/i )
233 "'".$field->{'default'}."'"
238 # Not null constraint
240 unless ( $field->{'null'} ) {
241 my $constraint_name = mk_name($field_name_ur, 'nn',undef,1);
242 $field_str .= ' NOT NULL';
245 $field_str .= ' NULL' if($data_type ne "bit");
248 push @field_decs, $field_str;
252 # Constraint Declarations
254 my @constraint_decs = ();
255 my $idx_name_default;
256 for my $constraint ( @{ $table->{'constraints'} } ) {
257 my $constraint_name = $constraint->{'name'} || '';
258 my $constraint_type = $constraint->{'type'} || 'normal';
259 my @fields = map { unreserve( $_, $table_name ) }
260 @{ $constraint->{'fields'} };
263 if ( $constraint_type eq 'primary_key' ) {
264 $constraint_name = mk_name( $table_name, 'pk',undef,1 );
266 'CONSTRAINT '.$constraint_name.' PRIMARY KEY '.
267 '(' . join( ', ', @fields ) . ')';
269 if ( $constraint_type eq 'foreign_key' ) {
270 $constraint_name = mk_name( $table_name, 'fk',undef,1 );
272 'CONSTRAINT '.$constraint_name.' FOREIGN KEY '.
273 '(' . join( ', ', @fields ) . ') '.
274 "REFERENCES $constraint->{'reference_table'}($constraint->{'reference_fields'}[0])";
276 elsif ( $constraint_type eq 'unique' ) {
277 $constraint_name = mk_name(
279 $constraint_name || ++$idx_name_default,undef, 1
282 'CONSTRAINT ' . $constraint_name . ' UNIQUE ' .
283 '(' . join( ', ', @fields ) . ')';
285 elsif ( $constraint_type eq 'normal' ) {
286 $constraint_name = mk_name(
288 $constraint_name || ++$idx_name_default, undef, 1
290 push @constraint_decs,
291 qq[CREATE CONSTRAINT "$constraint_name" on $table_name_ur (].
292 join( ', ', @fields ).
296 warn "Unknown constraint type ($constraint_type) on table $table_name.\n"
301 my $create_statement;
302 $create_statement = qq[DROP TABLE $table_name_ur;\n]
304 $create_statement .= qq[CREATE TABLE $table_name_ur (\n].
305 join( ",\n", map { " $_" } @field_decs, @constraints ).
309 $output .= join( "\n\n",
323 sort { $a->[0] <=> $b->[0] }
324 map { [ $_->{'order'}, $_ ] }
327 my $table_name = $table->{'table_name'};
328 $table_name = mk_name( $table_name, '', undef, 1 );
329 my $table_name_ur = unreserve($table_name);
332 for my $index ( @{ $table->{'indices'} } ) {
333 my $unique = ($index->{'name'} eq 'unique') ? 'unique' : '';
334 $output .= "CREATE $unique INDEX $index->{'name'} ".
335 "ON $table->{'table_name'} (".
336 join(',',@{$index->{'fields'}}).");\n";
342 warn "Truncated " . keys( %truncated ) . " names:\n";
343 warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
347 warn "Encounted " . keys( %unreserve ) .
348 " unsafe names in schema (reserved or invalid):\n";
349 warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
356 # -------------------------------------------------------------------
358 my ($basename, $type, $scope, $critical) = @_;
359 my $basename_orig = $basename;
361 ? $max_id_length - (length($type) + 1)
363 $basename = substr( $basename, 0, $max_name )
364 if length( $basename ) > $max_name;
365 my $name = $type ? "${type}_$basename" : $basename;
366 if ( $basename ne $basename_orig and $critical ) {
367 my $show_type = $type ? "+'$type'" : "";
368 warn "Truncating '$basename_orig'$show_type to $max_id_length ",
369 "character limit to make '$name'\n" if $WARN;
370 $truncated{ $basename_orig } = $name;
373 $scope ||= \%global_names;
374 if ( my $prev = $scope->{ $name } ) {
375 my $name_orig = $name;
376 $name .= sprintf( "%02d", ++$prev );
377 substr($name, $max_id_length - 3) = "00"
378 if length( $name ) > $max_id_length;
380 warn "The name '$name_orig' has been changed to ",
381 "'$name' to make it unique.\n" if $WARN;
383 $scope->{ $name_orig }++;
385 $name = substr( $name, 0, $max_id_length )
386 if ((length( $name ) > $max_id_length) && $critical);
391 # -------------------------------------------------------------------
393 my ( $name, $schema_obj_name ) = @_;
394 my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
396 # also trap fields that don't begin with a letter
397 return $_[0] if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
399 if ( $schema_obj_name ) {
400 ++$unreserve{"$schema_obj_name.$name"};
403 ++$unreserve{"$name (table name)"};
406 my $unreserve = sprintf '%s_', $name;
407 return $unreserve.$suffix;
412 # -------------------------------------------------------------------
418 Sam Angiuoli E<lt>angiuoli@users.sourceforge.netE<gt>,
419 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>