1 package SQL::Translator::Producer::Sybase;
3 # -------------------------------------------------------------------
4 # $Id: Sybase.pm,v 1.9 2004-02-09 23:02:17 kycl4rk Exp $
5 # -------------------------------------------------------------------
6 # Copyright (C) 2002-4 SQLFairy Authors
8 # This program is free software; you can redistribute it and/or
9 # modify it under the terms of the GNU General Public License as
10 # published by the Free Software Foundation; version 2.
12 # This program is distributed in the hope that it will be useful, but
13 # WITHOUT ANY WARRANTY; without even the implied warranty of
14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
15 # General Public License for more details.
17 # You should have received a copy of the GNU General Public License
18 # along with this program; if not, write to the Free Software
19 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
21 # -------------------------------------------------------------------
25 SQL::Translator::Producer::Sybase - Sybase producer for SQL::Translator
31 my $t = SQL::Translator->new( parser => '...', producer => 'Sybase' );
36 This module will produce text output of the schema suitable for Sybase.
41 use vars qw[ $DEBUG $WARN $VERSION ];
42 $VERSION = sprintf "%d.%02d", q$Revision: 1.9 $ =~ /(\d+)\.(\d+)/;
43 $DEBUG = 1 unless defined $DEBUG;
46 use SQL::Translator::Schema::Constants;
47 use SQL::Translator::Utils qw(debug header_comment);
58 varchar2 => 'varchar',
59 timestamp => 'datetime',
61 real => 'double precision',
64 tinyint => 'smallint',
65 float => 'double precision',
72 my %reserved = map { $_, 1 } qw[
73 ALL ANALYSE ANALYZE AND ANY AS ASC
75 CASE CAST CHECK COLLATE COLUMN CONSTRAINT CROSS
76 CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP CURRENT_USER
77 DEFAULT DEFERRABLE DESC DISTINCT DO
79 FALSE FOR FOREIGN FREEZE FROM FULL
81 ILIKE IN INITIALLY INNER INTERSECT INTO IS ISNULL
82 JOIN LEADING LEFT LIKE LIMIT
83 NATURAL NEW NOT NOTNULL NULL
84 OFF OFFSET OLD ON ONLY OR ORDER OUTER OVERLAPS
85 PRIMARY PUBLIC REFERENCES RIGHT
86 SELECT SESSION_USER SOME TABLE THEN TO TRAILING TRUE
87 UNION UNIQUE USER USING VERBOSE WHEN WHERE
90 my $max_id_length = 30;
91 my %used_identifiers = ();
98 =head1 Sybase Create Table Syntax
100 CREATE [ [ LOCAL ] { TEMPORARY | TEMP } ] TABLE table_name (
101 { column_name data_type [ DEFAULT default_expr ] [ column_constraint [, ... ] ]
102 | table_constraint } [, ... ]
104 [ INHERITS ( parent_table [, ... ] ) ]
105 [ WITH OIDS | WITHOUT OIDS ]
107 where column_constraint is:
109 [ CONSTRAINT constraint_name ]
110 { NOT NULL | NULL | UNIQUE | PRIMARY KEY |
112 REFERENCES reftable [ ( refcolumn ) ] [ MATCH FULL | MATCH PARTIAL ]
113 [ ON DELETE action ] [ ON UPDATE action ] }
114 [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
116 and table_constraint is:
118 [ CONSTRAINT constraint_name ]
119 { UNIQUE ( column_name [, ... ] ) |
120 PRIMARY KEY ( column_name [, ... ] ) |
121 CHECK ( expression ) |
122 FOREIGN KEY ( column_name [, ... ] ) REFERENCES reftable [ ( refcolumn [, ... ] ) ]
123 [ MATCH FULL | MATCH PARTIAL ] [ ON DELETE action ] [ ON UPDATE action ] }
124 [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
126 =head1 Create Index Syntax
128 CREATE [ UNIQUE ] INDEX index_name ON table
129 [ USING acc_method ] ( column [ ops_name ] [, ...] )
131 CREATE [ UNIQUE ] INDEX index_name ON table
132 [ USING acc_method ] ( func_name( column [, ... ]) [ ops_name ] )
137 # -------------------------------------------------------------------
139 my $translator = shift;
140 $DEBUG = $translator->debug;
141 $WARN = $translator->show_warnings;
142 my $no_comments = $translator->no_comments;
143 my $add_drop_table = $translator->add_drop_table;
144 my $schema = $translator->schema;
147 $output .= header_comment unless ($no_comments);
149 for my $table ( $schema->get_tables ) {
150 my $table_name = $table->name or next;
151 $table_name = mk_name( $table_name, '', undef, 1 );
152 my $table_name_ur = unreserve($table_name) || '';
154 my ( @comments, @field_defs, @index_defs, @constraint_defs );
156 push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;
158 push @comments, map { "-- $_" } $table->comments;
163 my %field_name_scope;
164 for my $field ( $table->get_fields ) {
165 my $field_name = mk_name(
166 $field->name, '', \%field_name_scope, undef,1
168 my $field_name_ur = unreserve( $field_name, $table_name );
169 my $field_def = qq["$field_name_ur"];
170 $field_def =~ s/\"//g;
171 if ( $field_def =~ /identity/ ){
172 $field_def =~ s/identity/pidentity/;
178 my $data_type = lc $field->data_type;
179 my $orig_data_type = $data_type;
180 my %extra = $field->extra;
181 my $list = $extra{'list'} || [];
182 # \todo deal with embedded quotes
183 my $commalist = join( ', ', map { qq['$_'] } @$list );
186 if ( $data_type eq 'enum' ) {
187 my $check_name = mk_name(
188 $table_name.'_'.$field_name, 'chk' ,undef, 1
190 push @constraint_defs,
191 "CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
192 $data_type .= 'character varying';
194 elsif ( $data_type eq 'set' ) {
195 $data_type .= 'character varying';
197 elsif ( $field->is_auto_increment ) {
198 $field_def .= ' IDENTITY';
201 if ( defined $translate{ $data_type } ) {
202 $data_type = $translate{ $data_type };
205 warn "Unknown datatype: $data_type ",
206 "($table_name.$field_name)\n" if $WARN;
210 my $size = $field->size;
212 if ( $data_type =~ /numeric/ ) {
215 elsif ( $orig_data_type eq 'text' ) {
216 #interpret text fields as long varchars
220 $data_type eq 'varchar' &&
221 $orig_data_type eq 'boolean'
225 elsif ( $data_type eq 'varchar' ) {
230 $field_def .= " $data_type";
231 $field_def .= "($size)" if $size;
236 my $default = $field->default_value;
237 if ( defined $default ) {
238 $field_def .= sprintf( ' DEFAULT %s',
239 ( $field->is_auto_increment && $seq_name )
240 ? qq[nextval('"$seq_name"'::text)] :
241 ( $default =~ m/null/i ) ? 'NULL' : "'$default'"
246 # Not null constraint
248 unless ( $field->is_nullable ) {
249 $field_def .= ' NOT NULL';
252 $field_def .= ' NULL' if $data_type ne 'bit';
255 push @field_defs, $field_def;
259 # Constraint Declarations
261 my @constraint_decs = ();
263 for my $constraint ( $table->get_constraints ) {
264 my $name = $constraint->name || '';
265 my $type = $constraint->type || NORMAL;
266 my @fields = map { unreserve( $_, $table_name ) }
268 my @rfields = map { unreserve( $_, $table_name ) }
269 $constraint->reference_fields;
272 if ( $type eq PRIMARY_KEY ) {
273 $name ||= mk_name( $table_name, 'pk', undef,1 );
274 push @constraint_defs,
275 "CONSTRAINT $name PRIMARY KEY ".
276 '(' . join( ', ', @fields ) . ')';
278 elsif ( $type eq FOREIGN_KEY ) {
279 $name ||= mk_name( $table_name, 'fk', undef,1 );
280 push @constraint_defs,
281 "CONSTRAINT $name FOREIGN KEY".
282 ' (' . join( ', ', @fields ) . ') REFERENCES '.
283 $constraint->reference_table.
284 ' (' . join( ', ', @rfields ) . ')';
286 elsif ( $type eq UNIQUE ) {
289 $name || ++$c_name_default,undef, 1
291 push @constraint_defs,
292 "CONSTRAINT $name UNIQUE " .
293 '(' . join( ', ', @fields ) . ')';
300 for my $index ( $table->get_indices ) {
302 'CREATE INDEX ' . $index->name .
304 join( ', ', $index->fields ) . ");";
307 my $create_statement;
308 $create_statement = qq[DROP TABLE $table_name_ur;\n]
310 $create_statement .= qq[CREATE TABLE $table_name_ur (\n].
312 map { " $_" } @field_defs, @constraint_defs
317 $output .= join( "\n\n",
325 foreach my $view ( $schema->get_views ) {
326 my (@comments, $view_name);
328 $view_name = $view->name();
329 push @comments, "--\n-- View: $view_name\n--" unless $no_comments;
331 # text of view is already a 'create view' statement so no need
332 # to do anything fancy.
334 $output .= join("\n\n",
341 foreach my $procedure ( $schema->get_procedures ) {
342 my (@comments, $procedure_name);
344 $procedure_name = $procedure->name();
346 "--\n-- Procedure: $procedure_name\n--" unless $no_comments;
348 # text of procedure already has the 'create procedure' stuff
349 # so there is no need to do anything fancy. However, we should
350 # think about doing fancy stuff with granting permissions and
353 $output .= join("\n\n",
361 warn "Truncated " . keys( %truncated ) . " names:\n";
362 warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
366 warn "Encounted " . keys( %unreserve ) .
367 " unsafe names in schema (reserved or invalid):\n";
368 warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
375 # -------------------------------------------------------------------
377 my $basename = shift || '';
378 my $type = shift || '';
379 my $scope = shift || '';
380 my $critical = shift || '';
381 my $basename_orig = $basename;
383 ? $max_id_length - (length($type) + 1)
385 $basename = substr( $basename, 0, $max_name )
386 if length( $basename ) > $max_name;
387 my $name = $type ? "${type}_$basename" : $basename;
389 if ( $basename ne $basename_orig and $critical ) {
390 my $show_type = $type ? "+'$type'" : "";
391 warn "Truncating '$basename_orig'$show_type to $max_id_length ",
392 "character limit to make '$name'\n" if $WARN;
393 $truncated{ $basename_orig } = $name;
396 $scope ||= \%global_names;
397 if ( my $prev = $scope->{ $name } ) {
398 my $name_orig = $name;
399 $name .= sprintf( "%02d", ++$prev );
400 substr($name, $max_id_length - 3) = "00"
401 if length( $name ) > $max_id_length;
403 warn "The name '$name_orig' has been changed to ",
404 "'$name' to make it unique.\n" if $WARN;
406 $scope->{ $name_orig }++;
408 $name = substr( $name, 0, $max_id_length )
409 if ((length( $name ) > $max_id_length) && $critical);
414 # -------------------------------------------------------------------
416 my $name = shift || '';
417 my $schema_obj_name = shift || '';
418 my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
420 # also trap fields that don't begin with a letter
421 return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
423 if ( $schema_obj_name ) {
424 ++$unreserve{"$schema_obj_name.$name"};
427 ++$unreserve{"$name (table name)"};
430 my $unreserve = sprintf '%s_', $name;
431 return $unreserve.$suffix;
436 # -------------------------------------------------------------------
446 Sam Angiuoli E<lt>angiuoli@users.sourceforge.netE<gt>,
447 Paul Harrington E<lt>harringp@deshaw.comE<gt>,
448 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.