1 package SQL::Translator::Producer::Sybase;
3 # -------------------------------------------------------------------
4 # $Id: Sybase.pm,v 1.1 2003-05-12 14:29:51 angiuoli Exp $
5 # -------------------------------------------------------------------
6 # Copyright (C) 2003 Ken Y. Clark <kclark@cpan.org>,
7 # darren chamberlain <darren@cpan.org>,
8 # Chris Mungall <cjm@fruitfly.org>
10 # This program is free software; you can redistribute it and/or
11 # modify it under the terms of the GNU General Public License as
12 # published by the Free Software Foundation; version 2.
14 # This program is distributed in the hope that it will be useful, but
15 # WITHOUT ANY WARRANTY; without even the implied warranty of
16 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
17 # General Public License for more details.
19 # You should have received a copy of the GNU General Public License
20 # along with this program; if not, write to the Free Software
21 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
23 # -------------------------------------------------------------------
27 SQL::Translator::Producer::Sybase - Sybase producer for SQL::Translator
32 use vars qw[ $DEBUG $WARN $VERSION ];
33 $VERSION = sprintf "%d.%02d", q$Revision: 1.1 $ =~ /(\d+)\.(\d+)/;
34 $DEBUG = 1 unless defined $DEBUG;
45 timestamp => 'datetime',
47 real => 'double precision',
50 tinyint => 'smallint',
51 float => 'double precision',
58 my %reserved = map { $_, 1 } qw[
59 ALL ANALYSE ANALYZE AND ANY AS ASC
61 CASE CAST CHECK COLLATE COLUMN CONSTRAINT CROSS
62 CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP CURRENT_USER
63 DEFAULT DEFERRABLE DESC DISTINCT DO
65 FALSE FOR FOREIGN FREEZE FROM FULL
67 ILIKE IN INITIALLY INNER INTERSECT INTO IS ISNULL
68 JOIN LEADING LEFT LIKE LIMIT
69 NATURAL NEW NOT NOTNULL NULL
70 OFF OFFSET OLD ON ONLY OR ORDER OUTER OVERLAPS
71 PRIMARY PUBLIC REFERENCES RIGHT
72 SELECT SESSION_USER SOME TABLE THEN TO TRAILING TRUE
73 UNION UNIQUE USER USING VERBOSE WHEN WHERE
76 my $max_id_length = 30;
77 my %used_identifiers = ();
84 =head1 Sybase Create Table Syntax
86 CREATE [ [ LOCAL ] { TEMPORARY | TEMP } ] TABLE table_name (
87 { column_name data_type [ DEFAULT default_expr ] [ column_constraint [, ... ] ]
88 | table_constraint } [, ... ]
90 [ INHERITS ( parent_table [, ... ] ) ]
91 [ WITH OIDS | WITHOUT OIDS ]
93 where column_constraint is:
95 [ CONSTRAINT constraint_name ]
96 { NOT NULL | NULL | UNIQUE | PRIMARY KEY |
98 REFERENCES reftable [ ( refcolumn ) ] [ MATCH FULL | MATCH PARTIAL ]
99 [ ON DELETE action ] [ ON UPDATE action ] }
100 [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
102 and table_constraint is:
104 [ CONSTRAINT constraint_name ]
105 { UNIQUE ( column_name [, ... ] ) |
106 PRIMARY KEY ( column_name [, ... ] ) |
107 CHECK ( expression ) |
108 FOREIGN KEY ( column_name [, ... ] ) REFERENCES reftable [ ( refcolumn [, ... ] ) ]
109 [ MATCH FULL | MATCH PARTIAL ] [ ON DELETE action ] [ ON UPDATE action ] }
110 [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
112 =head1 Create Index Syntax
114 CREATE [ UNIQUE ] INDEX index_name ON table
115 [ USING acc_method ] ( column [ ops_name ] [, ...] )
117 CREATE [ UNIQUE ] INDEX index_name ON table
118 [ USING acc_method ] ( func_name( column [, ... ]) [ ops_name ] )
123 # -------------------------------------------------------------------
125 my ( $translator, $data ) = @_;
126 $DEBUG = $translator->debug;
127 $WARN = $translator->show_warnings;
128 my $no_comments = $translator->no_comments;
129 my $add_drop_table = $translator->add_drop_table;
132 unless ( $no_comments ) {
134 "--\n-- Created by %s\n-- Created on %s\n--\n\n",
135 __PACKAGE__, scalar localtime;
140 sort { $a->[0] <=> $b->[0] }
141 map { [ $_->{'order'}, $_ ] }
144 my $table_name = $table->{'table_name'};
145 $table_name = mk_name( $table_name, '', undef, 1 );
146 my $table_name_ur = unreserve($table_name);
148 my ( @comments, @field_decs, @sequence_decs, @constraints );
150 push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;
155 my %field_name_scope;
158 sort { $a->[0] <=> $b->[0] }
159 map { [ $_->{'order'}, $_ ] }
160 values %{ $table->{'fields'} }
162 my $field_name = mk_name(
163 $field->{'name'}, '', \%field_name_scope, undef,1
165 my $field_name_ur = unreserve( $field_name, $table_name );
166 my $field_str = qq["$field_name_ur"];
167 $field_str =~ s/\"//g;
168 if ($field_str =~ /identity/){
169 $field_str =~ s/identity/pidentity/;
175 my $data_type = lc $field->{'data_type'};
176 my $orig_data_type = $data_type;
177 my $list = $field->{'list'} || [];
178 my $commalist = join ",", @$list;
181 if ( $data_type eq 'enum' ) {
183 $len = ($len < length($_)) ? length($_) : $len for (@$list);
184 my $check_name = mk_name( $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)';
210 if( $orig_data_type eq 'text'){
211 #interpret text fields as long varchars
212 $field_str .= '(255)';
214 elsif($data_type eq "varchar" && $orig_data_type eq "boolean"){
217 elsif($data_type eq "varchar" && (!$field->{'size'})){
218 $field_str .= '(255)';
226 if ( defined $field->{'default'} ) {
227 $field_str .= sprintf( ' DEFAULT %s',
228 ( $field->{'is_auto_inc'} && $seq_name )
229 ? qq[nextval('"$seq_name"'::text)] :
230 ( $field->{'default'} =~ m/null/i )
232 "'".$field->{'default'}."'"
237 # Not null constraint
239 unless ( $field->{'null'} ) {
240 my $constraint_name = mk_name($field_name_ur, 'nn',undef,1);
241 # $field_str .= ' CONSTRAINT '.$constraint_name.' NOT NULL';
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 );
265 push @constraints, 'CONSTRAINT '.$constraint_name.' PRIMARY KEY '.
266 '(' . join( ', ', @fields ) . ')';
268 if ( $constraint_type eq 'foreign_key' ) {
269 $constraint_name = mk_name( $table_name, 'fk',undef,1 );
270 push @constraints, 'CONSTRAINT '.$constraint_name.' FOREIGN KEY '.
271 '(' . join( ', ', @fields ) . ') '.
272 "REFERENCES $constraint->{'reference_table'}($constraint->{'reference_fields'}[0])";
274 elsif ( $constraint_type eq 'unique' ) {
275 $constraint_name = mk_name(
276 $table_name, $constraint_name || ++$idx_name_default,undef, 1
278 push @constraints, 'CONSTRAINT ' . $constraint_name . ' UNIQUE ' .
279 '(' . join( ', ', @fields ) . ')';
281 elsif ( $constraint_type eq 'normal' ) {
282 $constraint_name = mk_name(
283 $table_name, $constraint_name || ++$idx_name_default, undef, 1
285 push @constraint_decs,
286 qq[CREATE CONSTRAINT "$constraint_name" on $table_name_ur (].
287 join( ', ', @fields ).
291 warn "Unknown constraint type ($constraint_type) on table $table_name.\n"
296 my $create_statement;
297 $create_statement = qq[DROP TABLE $table_name_ur;\n]
299 $create_statement .= qq[CREATE TABLE $table_name_ur (\n].
300 join( ",\n", map { " $_" } @field_decs, @constraints ).
304 $output .= join( "\n\n",
317 sort { $a->[0] <=> $b->[0] }
318 map { [ $_->{'order'}, $_ ] }
321 my $table_name = $table->{'table_name'};
322 $table_name = mk_name( $table_name, '', undef, 1 );
323 my $table_name_ur = unreserve($table_name);
326 for my $index ( @{ $table->{'indices'} } ) {
327 my $unique = ($index->{'name'} eq 'unique') ? 'unique' : '';
328 $output .= "CREATE $unique INDEX $index->{'name'} ON $table->{'table_name'} (".join(',',@{$index->{'fields'}}).");\n";
333 warn "Truncated " . keys( %truncated ) . " names:\n";
334 warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
338 warn "Encounted " . keys( %unreserve ) .
339 " unsafe names in schema (reserved or invalid):\n";
340 warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
347 # -------------------------------------------------------------------
349 my ($basename, $type, $scope, $critical) = @_;
350 my $basename_orig = $basename;
352 ? $max_id_length - (length($type) + 1)
354 $basename = substr( $basename, 0, $max_name )
355 if length( $basename ) > $max_name;
356 my $name = $type ? "${type}_$basename" : $basename;
357 if ( $basename ne $basename_orig and $critical ) {
358 my $show_type = $type ? "+'$type'" : "";
359 warn "Truncating '$basename_orig'$show_type to $max_id_length ",
360 "character limit to make '$name'\n" if $WARN;
361 $truncated{ $basename_orig } = $name;
364 $scope ||= \%global_names;
365 if ( my $prev = $scope->{ $name } ) {
366 my $name_orig = $name;
367 $name .= sprintf( "%02d", ++$prev );
368 substr($name, $max_id_length - 3) = "00"
369 if length( $name ) > $max_id_length;
371 warn "The name '$name_orig' has been changed to ",
372 "'$name' to make it unique.\n" if $WARN;
374 $scope->{ $name_orig }++;
376 $name = substr( $name, 0, $max_id_length )
377 if ((length( $name ) > $max_id_length) && $critical);
382 # -------------------------------------------------------------------
384 my ( $name, $schema_obj_name ) = @_;
385 my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
387 # also trap fields that don't begin with a letter
388 return $_[0] if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
390 if ( $schema_obj_name ) {
391 ++$unreserve{"$schema_obj_name.$name"};
394 ++$unreserve{"$name (table name)"};
397 my $unreserve = sprintf '%s_', $name;
398 return $unreserve.$suffix;
403 # -------------------------------------------------------------------
404 # Life is full of misery, loneliness, and suffering --
405 # and it's all over much too soon.
407 # -------------------------------------------------------------------
413 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>