1 package SQL::Translator::Producer::Sybase;
5 SQL::Translator::Producer::Sybase - Sybase producer for SQL::Translator
11 my $t = SQL::Translator->new( parser => '...', producer => 'Sybase' );
16 This module will produce text output of the schema suitable for Sybase.
22 our ( $DEBUG, $WARN );
23 our $VERSION = '1.62';
24 $DEBUG = 1 unless defined $DEBUG;
27 use SQL::Translator::Schema::Constants;
28 use SQL::Translator::Utils qw(debug header_comment);
39 varchar2 => 'varchar',
40 timestamp => 'datetime',
42 real => 'double precision',
45 tinyint => 'smallint',
46 float => 'double precision',
53 my %reserved = map { $_, 1 } qw[
54 ALL ANALYSE ANALYZE AND ANY AS ASC
56 CASE CAST CHECK COLLATE COLUMN CONSTRAINT CROSS
57 CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP CURRENT_USER
58 DEFAULT DEFERRABLE DESC DISTINCT DO
60 FALSE FOR FOREIGN FREEZE FROM FULL
62 ILIKE IN INITIALLY INNER INTERSECT INTO IS ISNULL
63 JOIN LEADING LEFT LIKE LIMIT
64 NATURAL NEW NOT NOTNULL NULL
65 OFF OFFSET OLD ON ONLY OR ORDER OUTER OVERLAPS
66 PRIMARY PUBLIC REFERENCES RIGHT
67 SELECT SESSION_USER SOME TABLE THEN TO TRAILING TRUE
68 UNION UNIQUE USER USING VERBOSE WHEN WHERE
71 my $max_id_length = 30;
72 my %used_identifiers = ();
79 =head1 Sybase Create Table Syntax
81 CREATE [ [ LOCAL ] { TEMPORARY | TEMP } ] TABLE table_name (
82 { column_name data_type [ DEFAULT default_expr ] [ column_constraint [, ... ] ]
83 | table_constraint } [, ... ]
85 [ INHERITS ( parent_table [, ... ] ) ]
86 [ WITH OIDS | WITHOUT OIDS ]
88 where column_constraint is:
90 [ CONSTRAINT constraint_name ]
91 { NOT NULL | NULL | UNIQUE | PRIMARY KEY |
93 REFERENCES reftable [ ( refcolumn ) ] [ MATCH FULL | MATCH PARTIAL ]
94 [ ON DELETE action ] [ ON UPDATE action ] }
95 [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
97 and table_constraint is:
99 [ CONSTRAINT constraint_name ]
100 { UNIQUE ( column_name [, ... ] ) |
101 PRIMARY KEY ( column_name [, ... ] ) |
102 CHECK ( expression ) |
103 FOREIGN KEY ( column_name [, ... ] ) REFERENCES reftable [ ( refcolumn [, ... ] ) ]
104 [ MATCH FULL | MATCH PARTIAL ] [ ON DELETE action ] [ ON UPDATE action ] }
105 [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
107 =head1 Create Index Syntax
109 CREATE [ UNIQUE ] INDEX index_name ON table
110 [ USING acc_method ] ( column [ ops_name ] [, ...] )
112 CREATE [ UNIQUE ] INDEX index_name ON table
113 [ USING acc_method ] ( func_name( column [, ... ]) [ ops_name ] )
119 my $translator = shift;
120 $DEBUG = $translator->debug;
121 $WARN = $translator->show_warnings;
122 my $no_comments = $translator->no_comments;
123 my $add_drop_table = $translator->add_drop_table;
124 my $schema = $translator->schema;
127 push @output, header_comment unless ($no_comments);
131 for my $table ( $schema->get_tables ) {
132 my $table_name = $table->name or next;
133 $table_name = mk_name( $table_name, '', undef, 1 );
134 my $table_name_ur = unreserve($table_name) || '';
136 my ( @comments, @field_defs, @index_defs, @constraint_defs );
138 push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;
140 push @comments, map { "-- $_" } $table->comments;
145 my %field_name_scope;
146 for my $field ( $table->get_fields ) {
147 my $field_name = mk_name(
148 $field->name, '', \%field_name_scope, undef,1
150 my $field_name_ur = unreserve( $field_name, $table_name );
151 my $field_def = qq["$field_name_ur"];
152 $field_def =~ s/\"//g;
153 if ( $field_def =~ /identity/ ){
154 $field_def =~ s/identity/pidentity/;
160 my $data_type = lc $field->data_type;
161 my $orig_data_type = $data_type;
162 my %extra = $field->extra;
163 my $list = $extra{'list'} || [];
164 # \todo deal with embedded quotes
165 my $commalist = join( ', ', map { qq['$_'] } @$list );
170 if ( $data_type eq 'enum' ) {
171 my $check_name = mk_name(
172 $table_name.'_'.$field_name, 'chk' ,undef, 1
174 push @constraint_defs,
175 "CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
176 $data_type .= 'character varying';
178 elsif ( $data_type eq 'set' ) {
179 $data_type .= 'character varying';
182 if ( $field->is_auto_increment ) {
183 $identity = 'IDENTITY';
185 if ( defined $translate{ $data_type } ) {
186 $data_type = $translate{ $data_type };
189 warn "Unknown datatype: $data_type ",
190 "($table_name.$field_name)\n" if $WARN;
194 my $size = $field->size;
196 if ( $data_type =~ /numeric/ ) {
199 elsif ( $orig_data_type eq 'text' ) {
200 #interpret text fields as long varchars
204 $data_type eq 'varchar' &&
205 $orig_data_type eq 'boolean'
209 elsif ( $data_type eq 'varchar' ) {
214 $field_def .= " $data_type";
215 $field_def .= "($size)" if $size;
216 $field_def .= " $identity" if $identity;
221 my $default = $field->default_value;
222 if ( defined $default ) {
223 $field_def .= sprintf( ' DEFAULT %s',
224 ( $field->is_auto_increment && $seq_name )
225 ? qq[nextval('"$seq_name"'::text)] :
226 ( $default =~ m/null/i ) ? 'NULL' : "'$default'"
231 # Not null constraint
233 unless ( $field->is_nullable ) {
234 $field_def .= ' NOT NULL';
237 $field_def .= ' NULL' if $data_type ne 'bit';
240 push @field_defs, $field_def;
244 # Constraint Declarations
246 my @constraint_decs = ();
248 for my $constraint ( $table->get_constraints ) {
249 my $name = $constraint->name || '';
250 my $type = $constraint->type || NORMAL;
251 my @fields = map { unreserve( $_, $table_name ) }
253 my @rfields = map { unreserve( $_, $table_name ) }
254 $constraint->reference_fields;
257 if ( $type eq PRIMARY_KEY ) {
258 $name ||= mk_name( $table_name, 'pk', undef,1 );
259 push @constraint_defs,
260 "CONSTRAINT $name PRIMARY KEY ".
261 '(' . join( ', ', @fields ) . ')';
263 elsif ( $type eq FOREIGN_KEY ) {
264 $name ||= mk_name( $table_name, 'fk', undef,1 );
266 "ALTER TABLE $table ADD CONSTRAINT $name FOREIGN KEY".
267 ' (' . join( ', ', @fields ) . ') REFERENCES '.
268 $constraint->reference_table.
269 ' (' . join( ', ', @rfields ) . ')';
271 elsif ( $type eq UNIQUE ) {
274 $name || ++$c_name_default,undef, 1
276 push @constraint_defs,
277 "CONSTRAINT $name UNIQUE " .
278 '(' . join( ', ', @fields ) . ')';
285 for my $index ( $table->get_indices ) {
287 'CREATE INDEX ' . $index->name .
289 join( ', ', $index->fields ) . ")";
292 my $drop_statement = $add_drop_table
293 ? qq[DROP TABLE $table_name_ur] : '';
294 my $create_statement = qq[CREATE TABLE $table_name_ur (\n].
296 map { " $_" } @field_defs, @constraint_defs
301 $create_statement = join("\n\n", @comments) . "\n\n" . $create_statement;
308 foreach my $view ( $schema->get_views ) {
309 my (@comments, $view_name);
311 $view_name = $view->name();
312 push @comments, "--\n-- View: $view_name\n--" unless $no_comments;
314 # text of view is already a 'create view' statement so no need
315 # to do anything fancy.
317 push @output, join("\n\n",
324 foreach my $procedure ( $schema->get_procedures ) {
325 my (@comments, $procedure_name);
327 $procedure_name = $procedure->name();
329 "--\n-- Procedure: $procedure_name\n--" unless $no_comments;
331 # text of procedure already has the 'create procedure' stuff
332 # so there is no need to do anything fancy. However, we should
333 # think about doing fancy stuff with granting permissions and
336 push @output, join("\n\n",
341 push @output, @foreign_keys;
345 warn "Truncated " . keys( %truncated ) . " names:\n";
346 warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
350 warn "Encounted " . keys( %unreserve ) .
351 " unsafe names in schema (reserved or invalid):\n";
352 warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
356 return wantarray ? @output : join ";\n\n", @output;
360 my $basename = shift || '';
361 my $type = shift || '';
362 my $scope = shift || '';
363 my $critical = shift || '';
364 my $basename_orig = $basename;
366 ? $max_id_length - (length($type) + 1)
368 $basename = substr( $basename, 0, $max_name )
369 if length( $basename ) > $max_name;
370 my $name = $type ? "${type}_$basename" : $basename;
372 if ( $basename ne $basename_orig and $critical ) {
373 my $show_type = $type ? "+'$type'" : "";
374 warn "Truncating '$basename_orig'$show_type to $max_id_length ",
375 "character limit to make '$name'\n" if $WARN;
376 $truncated{ $basename_orig } = $name;
379 $scope ||= \%global_names;
380 if ( my $prev = $scope->{ $name } ) {
381 my $name_orig = $name;
382 $name .= sprintf( "%02d", ++$prev );
383 substr($name, $max_id_length - 3) = "00"
384 if length( $name ) > $max_id_length;
386 warn "The name '$name_orig' has been changed to ",
387 "'$name' to make it unique.\n" if $WARN;
389 $scope->{ $name_orig }++;
391 $name = substr( $name, 0, $max_id_length )
392 if ((length( $name ) > $max_id_length) && $critical);
398 my $name = shift || '';
399 my $schema_obj_name = shift || '';
400 my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
402 # also trap fields that don't begin with a letter
403 return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
405 if ( $schema_obj_name ) {
406 ++$unreserve{"$schema_obj_name.$name"};
409 ++$unreserve{"$name (table name)"};
412 my $unreserve = sprintf '%s_', $name;
413 return $unreserve.$suffix;
426 Sam Angiuoli E<lt>angiuoli@users.sourceforge.netE<gt>,
427 Paul Harrington E<lt>harringp@deshaw.comE<gt>,
428 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>.