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.60';
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 $output .= header_comment unless ($no_comments);
129 for my $table ( $schema->get_tables ) {
130 my $table_name = $table->name or next;
131 $table_name = mk_name( $table_name, '', undef, 1 );
132 my $table_name_ur = unreserve($table_name) || '';
134 my ( @comments, @field_defs, @index_defs, @constraint_defs );
136 push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;
138 push @comments, map { "-- $_" } $table->comments;
143 my %field_name_scope;
144 for my $field ( $table->get_fields ) {
145 my $field_name = mk_name(
146 $field->name, '', \%field_name_scope, undef,1
148 my $field_name_ur = unreserve( $field_name, $table_name );
149 my $field_def = qq["$field_name_ur"];
150 $field_def =~ s/\"//g;
151 if ( $field_def =~ /identity/ ){
152 $field_def =~ s/identity/pidentity/;
158 my $data_type = lc $field->data_type;
159 my $orig_data_type = $data_type;
160 my %extra = $field->extra;
161 my $list = $extra{'list'} || [];
162 # \todo deal with embedded quotes
163 my $commalist = join( ', ', map { qq['$_'] } @$list );
168 if ( $data_type eq 'enum' ) {
169 my $check_name = mk_name(
170 $table_name.'_'.$field_name, 'chk' ,undef, 1
172 push @constraint_defs,
173 "CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
174 $data_type .= 'character varying';
176 elsif ( $data_type eq 'set' ) {
177 $data_type .= 'character varying';
180 if ( $field->is_auto_increment ) {
181 $identity = 'IDENTITY';
183 if ( defined $translate{ $data_type } ) {
184 $data_type = $translate{ $data_type };
187 warn "Unknown datatype: $data_type ",
188 "($table_name.$field_name)\n" if $WARN;
192 my $size = $field->size;
194 if ( $data_type =~ /numeric/ ) {
197 elsif ( $orig_data_type eq 'text' ) {
198 #interpret text fields as long varchars
202 $data_type eq 'varchar' &&
203 $orig_data_type eq 'boolean'
207 elsif ( $data_type eq 'varchar' ) {
212 $field_def .= " $data_type";
213 $field_def .= "($size)" if $size;
214 $field_def .= " $identity" if $identity;
219 my $default = $field->default_value;
220 if ( defined $default ) {
221 $field_def .= sprintf( ' DEFAULT %s',
222 ( $field->is_auto_increment && $seq_name )
223 ? qq[nextval('"$seq_name"'::text)] :
224 ( $default =~ m/null/i ) ? 'NULL' : "'$default'"
229 # Not null constraint
231 unless ( $field->is_nullable ) {
232 $field_def .= ' NOT NULL';
235 $field_def .= ' NULL' if $data_type ne 'bit';
238 push @field_defs, $field_def;
242 # Constraint Declarations
244 my @constraint_decs = ();
246 for my $constraint ( $table->get_constraints ) {
247 my $name = $constraint->name || '';
248 my $type = $constraint->type || NORMAL;
249 my @fields = map { unreserve( $_, $table_name ) }
251 my @rfields = map { unreserve( $_, $table_name ) }
252 $constraint->reference_fields;
255 if ( $type eq PRIMARY_KEY ) {
256 $name ||= mk_name( $table_name, 'pk', undef,1 );
257 push @constraint_defs,
258 "CONSTRAINT $name PRIMARY KEY ".
259 '(' . join( ', ', @fields ) . ')';
261 elsif ( $type eq FOREIGN_KEY ) {
262 $name ||= mk_name( $table_name, 'fk', undef,1 );
263 push @constraint_defs,
264 "CONSTRAINT $name FOREIGN KEY".
265 ' (' . join( ', ', @fields ) . ') REFERENCES '.
266 $constraint->reference_table.
267 ' (' . join( ', ', @rfields ) . ')';
269 elsif ( $type eq UNIQUE ) {
272 $name || ++$c_name_default,undef, 1
274 push @constraint_defs,
275 "CONSTRAINT $name UNIQUE " .
276 '(' . join( ', ', @fields ) . ')';
283 for my $index ( $table->get_indices ) {
285 'CREATE INDEX ' . $index->name .
287 join( ', ', $index->fields ) . ");";
290 my $create_statement;
291 $create_statement = qq[DROP TABLE $table_name_ur;\n]
293 $create_statement .= qq[CREATE TABLE $table_name_ur (\n].
295 map { " $_" } @field_defs, @constraint_defs
300 $output .= join( "\n\n",
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 $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 $output .= join("\n\n",
344 warn "Truncated " . keys( %truncated ) . " names:\n";
345 warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
349 warn "Encounted " . keys( %unreserve ) .
350 " unsafe names in schema (reserved or invalid):\n";
351 warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
359 my $basename = shift || '';
360 my $type = shift || '';
361 my $scope = shift || '';
362 my $critical = shift || '';
363 my $basename_orig = $basename;
365 ? $max_id_length - (length($type) + 1)
367 $basename = substr( $basename, 0, $max_name )
368 if length( $basename ) > $max_name;
369 my $name = $type ? "${type}_$basename" : $basename;
371 if ( $basename ne $basename_orig and $critical ) {
372 my $show_type = $type ? "+'$type'" : "";
373 warn "Truncating '$basename_orig'$show_type to $max_id_length ",
374 "character limit to make '$name'\n" if $WARN;
375 $truncated{ $basename_orig } = $name;
378 $scope ||= \%global_names;
379 if ( my $prev = $scope->{ $name } ) {
380 my $name_orig = $name;
381 $name .= sprintf( "%02d", ++$prev );
382 substr($name, $max_id_length - 3) = "00"
383 if length( $name ) > $max_id_length;
385 warn "The name '$name_orig' has been changed to ",
386 "'$name' to make it unique.\n" if $WARN;
388 $scope->{ $name_orig }++;
390 $name = substr( $name, 0, $max_id_length )
391 if ((length( $name ) > $max_id_length) && $critical);
397 my $name = shift || '';
398 my $schema_obj_name = shift || '';
399 my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
401 # also trap fields that don't begin with a letter
402 return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
404 if ( $schema_obj_name ) {
405 ++$unreserve{"$schema_obj_name.$name"};
408 ++$unreserve{"$name (table name)"};
411 my $unreserve = sprintf '%s_', $name;
412 return $unreserve.$suffix;
425 Sam Angiuoli E<lt>angiuoli@users.sourceforge.netE<gt>,
426 Paul Harrington E<lt>harringp@deshaw.comE<gt>,
427 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>.