1 package SQL::Translator::Producer::Sybase;
3 # -------------------------------------------------------------------
4 # $Id: Sybase.pm,v 1.8 2003-10-15 19:16:32 kycl4rk Exp $
5 # -------------------------------------------------------------------
6 # Copyright (C) 2003 Ken Y. Clark <kclark@cpan.org>,
7 # Paul Harrington <harringp@deshaw.com>,
8 # Sam Angiuoli <angiuoli@users.sourceforge.net>.
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
33 my $t = SQL::Translator->new( parser => '...', producer => 'Sybase' );
38 This module will produce text output of the schema suitable for Sybase.
43 use vars qw[ $DEBUG $WARN $VERSION ];
44 $VERSION = sprintf "%d.%02d", q$Revision: 1.8 $ =~ /(\d+)\.(\d+)/;
45 $DEBUG = 1 unless defined $DEBUG;
48 use SQL::Translator::Schema::Constants;
49 use SQL::Translator::Utils qw(debug header_comment);
60 varchar2 => 'varchar',
61 timestamp => 'datetime',
63 real => 'double precision',
66 tinyint => 'smallint',
67 float => 'double precision',
74 my %reserved = map { $_, 1 } qw[
75 ALL ANALYSE ANALYZE AND ANY AS ASC
77 CASE CAST CHECK COLLATE COLUMN CONSTRAINT CROSS
78 CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP CURRENT_USER
79 DEFAULT DEFERRABLE DESC DISTINCT DO
81 FALSE FOR FOREIGN FREEZE FROM FULL
83 ILIKE IN INITIALLY INNER INTERSECT INTO IS ISNULL
84 JOIN LEADING LEFT LIKE LIMIT
85 NATURAL NEW NOT NOTNULL NULL
86 OFF OFFSET OLD ON ONLY OR ORDER OUTER OVERLAPS
87 PRIMARY PUBLIC REFERENCES RIGHT
88 SELECT SESSION_USER SOME TABLE THEN TO TRAILING TRUE
89 UNION UNIQUE USER USING VERBOSE WHEN WHERE
92 my $max_id_length = 30;
93 my %used_identifiers = ();
100 =head1 Sybase Create Table Syntax
102 CREATE [ [ LOCAL ] { TEMPORARY | TEMP } ] TABLE table_name (
103 { column_name data_type [ DEFAULT default_expr ] [ column_constraint [, ... ] ]
104 | table_constraint } [, ... ]
106 [ INHERITS ( parent_table [, ... ] ) ]
107 [ WITH OIDS | WITHOUT OIDS ]
109 where column_constraint is:
111 [ CONSTRAINT constraint_name ]
112 { NOT NULL | NULL | UNIQUE | PRIMARY KEY |
114 REFERENCES reftable [ ( refcolumn ) ] [ MATCH FULL | MATCH PARTIAL ]
115 [ ON DELETE action ] [ ON UPDATE action ] }
116 [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
118 and table_constraint is:
120 [ CONSTRAINT constraint_name ]
121 { UNIQUE ( column_name [, ... ] ) |
122 PRIMARY KEY ( column_name [, ... ] ) |
123 CHECK ( expression ) |
124 FOREIGN KEY ( column_name [, ... ] ) REFERENCES reftable [ ( refcolumn [, ... ] ) ]
125 [ MATCH FULL | MATCH PARTIAL ] [ ON DELETE action ] [ ON UPDATE action ] }
126 [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
128 =head1 Create Index Syntax
130 CREATE [ UNIQUE ] INDEX index_name ON table
131 [ USING acc_method ] ( column [ ops_name ] [, ...] )
133 CREATE [ UNIQUE ] INDEX index_name ON table
134 [ USING acc_method ] ( func_name( column [, ... ]) [ ops_name ] )
139 # -------------------------------------------------------------------
141 my $translator = shift;
142 $DEBUG = $translator->debug;
143 $WARN = $translator->show_warnings;
144 my $no_comments = $translator->no_comments;
145 my $add_drop_table = $translator->add_drop_table;
146 my $schema = $translator->schema;
149 $output .= header_comment unless ($no_comments);
151 for my $table ( $schema->get_tables ) {
152 my $table_name = $table->name or next;
153 $table_name = mk_name( $table_name, '', undef, 1 );
154 my $table_name_ur = unreserve($table_name) || '';
156 my ( @comments, @field_defs, @index_defs, @constraint_defs );
158 push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;
160 push @comments, map { "-- $_" } $table->comments;
165 my %field_name_scope;
166 for my $field ( $table->get_fields ) {
167 my $field_name = mk_name(
168 $field->name, '', \%field_name_scope, undef,1
170 my $field_name_ur = unreserve( $field_name, $table_name );
171 my $field_def = qq["$field_name_ur"];
172 $field_def =~ s/\"//g;
173 if ( $field_def =~ /identity/ ){
174 $field_def =~ s/identity/pidentity/;
180 my $data_type = lc $field->data_type;
181 my $orig_data_type = $data_type;
182 my %extra = $field->extra;
183 my $list = $extra{'list'} || [];
184 # \todo deal with embedded quotes
185 my $commalist = join( ', ', map { qq['$_'] } @$list );
188 if ( $data_type eq 'enum' ) {
189 my $check_name = mk_name(
190 $table_name.'_'.$field_name, 'chk' ,undef, 1
192 push @constraint_defs,
193 "CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
194 $data_type .= 'character varying';
196 elsif ( $data_type eq 'set' ) {
197 $data_type .= 'character varying';
199 elsif ( $field->is_auto_increment ) {
200 $field_def .= ' IDENTITY';
203 if ( defined $translate{ $data_type } ) {
204 $data_type = $translate{ $data_type };
207 warn "Unknown datatype: $data_type ",
208 "($table_name.$field_name)\n" if $WARN;
212 my $size = $field->size;
214 if ( $data_type =~ /numeric/ ) {
217 elsif ( $orig_data_type eq 'text' ) {
218 #interpret text fields as long varchars
222 $data_type eq 'varchar' &&
223 $orig_data_type eq 'boolean'
227 elsif ( $data_type eq 'varchar' ) {
232 $field_def .= " $data_type";
233 $field_def .= "($size)" if $size;
238 my $default = $field->default_value;
239 if ( defined $default ) {
240 $field_def .= sprintf( ' DEFAULT %s',
241 ( $field->is_auto_increment && $seq_name )
242 ? qq[nextval('"$seq_name"'::text)] :
243 ( $default =~ m/null/i ) ? 'NULL' : "'$default'"
248 # Not null constraint
250 unless ( $field->is_nullable ) {
251 $field_def .= ' NOT NULL';
254 $field_def .= ' NULL' if $data_type ne 'bit';
257 push @field_defs, $field_def;
261 # Constraint Declarations
263 my @constraint_decs = ();
265 for my $constraint ( $table->get_constraints ) {
266 my $name = $constraint->name || '';
267 my $type = $constraint->type || NORMAL;
268 my @fields = map { unreserve( $_, $table_name ) }
270 my @rfields = map { unreserve( $_, $table_name ) }
271 $constraint->reference_fields;
274 if ( $type eq PRIMARY_KEY ) {
275 $name ||= mk_name( $table_name, 'pk', undef,1 );
276 push @constraint_defs,
277 "CONSTRAINT $name PRIMARY KEY ".
278 '(' . join( ', ', @fields ) . ')';
280 elsif ( $type eq FOREIGN_KEY ) {
281 $name ||= mk_name( $table_name, 'fk', undef,1 );
282 push @constraint_defs,
283 "CONSTRAINT $name FOREIGN KEY".
284 ' (' . join( ', ', @fields ) . ') REFERENCES '.
285 $constraint->reference_table.
286 ' (' . join( ', ', @rfields ) . ')';
288 elsif ( $type eq UNIQUE ) {
291 $name || ++$c_name_default,undef, 1
293 push @constraint_defs,
294 "CONSTRAINT $name UNIQUE " .
295 '(' . join( ', ', @fields ) . ')';
302 for my $index ( $table->get_indices ) {
304 'CREATE INDEX ' . $index->name .
306 join( ', ', $index->fields ) . ");";
309 my $create_statement;
310 $create_statement = qq[DROP TABLE $table_name_ur;\n]
312 $create_statement .= qq[CREATE TABLE $table_name_ur (\n].
314 map { " $_" } @field_defs, @constraint_defs
319 $output .= join( "\n\n",
327 foreach my $view ( $schema->get_views ) {
328 my (@comments, $view_name);
330 $view_name = $view->name();
331 push @comments, "--\n-- View: $view_name\n--" unless $no_comments;
333 # text of view is already a 'create view' statement so no need
334 # to do anything fancy.
336 $output .= join("\n\n",
343 foreach my $procedure ( $schema->get_procedures ) {
344 my (@comments, $procedure_name);
346 $procedure_name = $procedure->name();
348 "--\n-- Procedure: $procedure_name\n--" unless $no_comments;
350 # text of procedure already has the 'create procedure' stuff
351 # so there is no need to do anything fancy. However, we should
352 # think about doing fancy stuff with granting permissions and
355 $output .= join("\n\n",
363 warn "Truncated " . keys( %truncated ) . " names:\n";
364 warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
368 warn "Encounted " . keys( %unreserve ) .
369 " unsafe names in schema (reserved or invalid):\n";
370 warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
377 # -------------------------------------------------------------------
379 my $basename = shift || '';
380 my $type = shift || '';
381 my $scope = shift || '';
382 my $critical = shift || '';
383 my $basename_orig = $basename;
385 ? $max_id_length - (length($type) + 1)
387 $basename = substr( $basename, 0, $max_name )
388 if length( $basename ) > $max_name;
389 my $name = $type ? "${type}_$basename" : $basename;
391 if ( $basename ne $basename_orig and $critical ) {
392 my $show_type = $type ? "+'$type'" : "";
393 warn "Truncating '$basename_orig'$show_type to $max_id_length ",
394 "character limit to make '$name'\n" if $WARN;
395 $truncated{ $basename_orig } = $name;
398 $scope ||= \%global_names;
399 if ( my $prev = $scope->{ $name } ) {
400 my $name_orig = $name;
401 $name .= sprintf( "%02d", ++$prev );
402 substr($name, $max_id_length - 3) = "00"
403 if length( $name ) > $max_id_length;
405 warn "The name '$name_orig' has been changed to ",
406 "'$name' to make it unique.\n" if $WARN;
408 $scope->{ $name_orig }++;
410 $name = substr( $name, 0, $max_id_length )
411 if ((length( $name ) > $max_id_length) && $critical);
416 # -------------------------------------------------------------------
418 my $name = shift || '';
419 my $schema_obj_name = shift || '';
420 my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
422 # also trap fields that don't begin with a letter
423 return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
425 if ( $schema_obj_name ) {
426 ++$unreserve{"$schema_obj_name.$name"};
429 ++$unreserve{"$name (table name)"};
432 my $unreserve = sprintf '%s_', $name;
433 return $unreserve.$suffix;
438 # -------------------------------------------------------------------
448 Sam Angiuoli E<lt>angiuoli@users.sourceforge.netE<gt>,
449 Paul Harrington E<lt>harringp@deshaw.comE<gt>,
450 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.