lib/SQL/Translator/Producer/Sybase.pm

   1 package SQL::Translator::Producer::Sybase;
   2
   3 =head1 NAME
   4
   5 SQL::Translator::Producer::Sybase - Sybase producer for SQL::Translator
   6
   7 =head1 SYNOPSIS
   8
   9   use SQL::Translator;
  10
  11   my $t = SQL::Translator->new( parser => '...', producer => 'Sybase' );
  12   $t->translate;
  13
  14 =head1 DESCRIPTION
  15
  16 This module will produce text output of the schema suitable for Sybase.
  17
  18 =cut
  19
  20 use strict;
  21 use warnings;
  22 our ( $DEBUG, $WARN );
  23 our $VERSION = '1.62';
  24 $DEBUG = 1 unless defined $DEBUG;
  25
  26 use Data::Dumper;
  27 use SQL::Translator::Schema::Constants;
  28 use SQL::Translator::Utils qw(debug header_comment);
  29
  30 my %translate  = (
  31     #
  32     # Sybase types
  33     #
  34     integer   => 'numeric',
  35     int       => 'numeric',
  36     number    => 'numeric',
  37     money     => 'money',
  38     varchar   => 'varchar',
  39     varchar2  => 'varchar',
  40     timestamp => 'datetime',
  41     text      => 'varchar',
  42     real      => 'double precision',
  43     comment   => 'text',
  44     bit       => 'bit',
  45     tinyint   => 'smallint',
  46     float     => 'double precision',
  47     serial    => 'numeric',
  48     boolean   => 'varchar',
  49     char      => 'char',
  50     long      => 'varchar',
  51 );
  52
  53 my %reserved = map { $_, 1 } qw[
  54     ALL ANALYSE ANALYZE AND ANY AS ASC
  55     BETWEEN BINARY BOTH
  56     CASE CAST CHECK COLLATE COLUMN CONSTRAINT CROSS
  57     CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP CURRENT_USER
  58     DEFAULT DEFERRABLE DESC DISTINCT DO
  59     ELSE END EXCEPT
  60     FALSE FOR FOREIGN FREEZE FROM FULL
  61     GROUP HAVING
  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
  69 ];
  70
  71 my $max_id_length    = 30;
  72 my %used_identifiers = ();
  73 my %global_names;
  74 my %unreserve;
  75 my %truncated;
  76
  77 =pod
  78
  79 =head1 Sybase Create Table Syntax
  80
  81   CREATE [ [ LOCAL ] { TEMPORARY | TEMP } ] TABLE table_name (
  82       { column_name data_type [ DEFAULT default_expr ] [ column_constraint [, ... ] ]
  83       | table_constraint }  [, ... ]
  84   )
  85   [ INHERITS ( parent_table [, ... ] ) ]
  86   [ WITH OIDS | WITHOUT OIDS ]
  87
  88 where column_constraint is:
  89
  90   [ CONSTRAINT constraint_name ]
  91   { NOT NULL | NULL | UNIQUE | PRIMARY KEY |
  92     CHECK (expression) |
  93     REFERENCES reftable [ ( refcolumn ) ] [ MATCH FULL | MATCH PARTIAL ]
  94       [ ON DELETE action ] [ ON UPDATE action ] }
  95   [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
  96
  97 and table_constraint is:
  98
  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 ]
 106
 107 =head1 Create Index Syntax
 108
 109   CREATE [ UNIQUE ] INDEX index_name ON table
 110       [ USING acc_method ] ( column [ ops_name ] [, ...] )
 111       [ WHERE predicate ]
 112   CREATE [ UNIQUE ] INDEX index_name ON table
 113       [ USING acc_method ] ( func_name( column [, ... ]) [ ops_name ] )
 114       [ WHERE predicate ]
 115
 116 =cut
 117
 118 sub produce {
 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;
 125
 126     my @output;
 127     push @output, header_comment unless ($no_comments);
 128
 129     my @foreign_keys;
 130
 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) || '';
 135
 136         my ( @comments, @field_defs, @index_defs, @constraint_defs );
 137
 138         push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;
 139
 140         push @comments, map { "-- $_" } $table->comments;
 141
 142         #
 143         # Fields
 144         #
 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
 149             );
 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/;
 155             }
 156
 157             #
 158             # Datatype
 159             #
 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 );
 166             my $seq_name;
 167
 168             my $identity = '';
 169
 170             if ( $data_type eq 'enum' ) {
 171                 my $check_name = mk_name(
 172                     $table_name.'_'.$field_name, 'chk' ,undef, 1
 173                 );
 174                 push @constraint_defs,
 175                 "CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
 176                 $data_type .= 'character varying';
 177             }
 178             elsif ( $data_type eq 'set' ) {
 179                 $data_type .= 'character varying';
 180             }
 181             else {
 182                 if ( $field->is_auto_increment ) {
 183                     $identity = 'IDENTITY';
 184                 }
 185                 if ( defined $translate{ $data_type } ) {
 186                     $data_type = $translate{ $data_type };
 187                 }
 188                 else {
 189                     warn "Unknown datatype: $data_type ",
 190                         "($table_name.$field_name)\n" if $WARN;
 191                 }
 192             }
 193
 194             my $size = $field->size;
 195             unless ( $size ) {
 196                 if ( $data_type =~ /numeric/ ) {
 197                     $size = '9,0';
 198                 }
 199                 elsif ( $orig_data_type eq 'text' ) {
 200                     #interpret text fields as long varchars
 201                     $size = '255';
 202                 }
 203                 elsif (
 204                     $data_type eq 'varchar' &&
 205                     $orig_data_type eq 'boolean'
 206                 ) {
 207                     $size = '6';
 208                 }
 209                 elsif ( $data_type eq 'varchar' ) {
 210                     $size = '255';
 211                 }
 212             }
 213
 214             $field_def .= " $data_type";
 215             $field_def .= "($size)" if $size;
 216             $field_def .= " $identity" if $identity;
 217
 218             #
 219             # Default value
 220             #
 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'"
 227                 );
 228             }
 229
 230             #
 231             # Not null constraint
 232             #
 233             unless ( $field->is_nullable ) {
 234                 $field_def .= ' NOT NULL';
 235             }
 236             else {
 237                 $field_def .= ' NULL' if $data_type ne 'bit';
 238             }
 239
 240             push @field_defs, $field_def;
 241         }
 242
 243         #
 244         # Constraint Declarations
 245         #
 246         my @constraint_decs = ();
 247         my $c_name_default;
 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 ) }
 252                 $constraint->fields;
 253             my @rfields = map { unreserve( $_, $table_name ) }
 254                 $constraint->reference_fields;
 255             next unless @fields;
 256
 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 ) . ')';
 262             }
 263             elsif ( $type eq FOREIGN_KEY ) {
 264                 $name ||= mk_name( $table_name, 'fk', undef,1 );
 265                 push @foreign_keys,
 266                     "ALTER TABLE $table ADD CONSTRAINT $name FOREIGN KEY".
 267                     ' (' . join( ', ', @fields ) . ') REFERENCES '.
 268                     $constraint->reference_table.
 269                     ' (' . join( ', ', @rfields ) . ')';
 270             }
 271             elsif ( $type eq UNIQUE ) {
 272                 $name ||= mk_name(
 273                     $table_name,
 274                     $name || ++$c_name_default,undef, 1
 275                 );
 276                 push @constraint_defs,
 277                     "CONSTRAINT $name UNIQUE " .
 278                     '(' . join( ', ', @fields ) . ')';
 279             }
 280         }
 281
 282         #
 283         # Indices
 284         #
 285         for my $index ( $table->get_indices ) {
 286             push @index_defs,
 287                 'CREATE INDEX ' . $index->name .
 288                 " ON $table_name (".
 289                 join( ', ', $index->fields ) . ")";
 290         }
 291
 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].
 295             join( ",\n",
 296                 map { "  $_" } @field_defs, @constraint_defs
 297             ).
 298             "\n)"
 299         ;
 300
 301         $create_statement = join("\n\n", @comments) . "\n\n" . $create_statement;
 302         push @output,
 303             $create_statement,
 304             @index_defs,
 305         ;
 306     }
 307
 308     foreach my $view ( $schema->get_views ) {
 309         my (@comments, $view_name);
 310
 311         $view_name = $view->name();
 312         push @comments, "--\n-- View: $view_name\n--" unless $no_comments;
 313
 314         # text of view is already a 'create view' statement so no need
 315         # to do anything fancy.
 316
 317         push @output, join("\n\n",
 318                        @comments,
 319                        $view->sql(),
 320                        );
 321     }
 322
 323
 324     foreach my $procedure ( $schema->get_procedures ) {
 325         my (@comments, $procedure_name);
 326
 327         $procedure_name = $procedure->name();
 328         push @comments,
 329             "--\n-- Procedure: $procedure_name\n--" unless $no_comments;
 330
 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
 334         # so on.
 335
 336         push @output, join("\n\n",
 337                        @comments,
 338                        $procedure->sql(),
 339                        );
 340     }
 341     push @output, @foreign_keys;
 342
 343     if ( $WARN ) {
 344         if ( %truncated ) {
 345             warn "Truncated " . keys( %truncated ) . " names:\n";
 346             warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
 347         }
 348
 349         if ( %unreserve ) {
 350             warn "Encounted " . keys( %unreserve ) .
 351                 " unsafe names in schema (reserved or invalid):\n";
 352             warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
 353         }
 354     }
 355
 356     return wantarray ? @output : join ";\n\n", @output;
 357 }
 358
 359 sub mk_name {
 360     my $basename      = shift || '';
 361     my $type          = shift || '';
 362     my $scope         = shift || '';
 363     my $critical      = shift || '';
 364     my $basename_orig = $basename;
 365     my $max_name      = $type
 366                         ? $max_id_length - (length($type) + 1)
 367                         : $max_id_length;
 368     $basename         = substr( $basename, 0, $max_name )
 369                         if length( $basename ) > $max_name;
 370     my $name          = $type ? "${type}_$basename" : $basename;
 371
 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;
 377     }
 378
 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;
 385
 386         warn "The name '$name_orig' has been changed to ",
 387              "'$name' to make it unique.\n" if $WARN;
 388
 389         $scope->{ $name_orig }++;
 390     }
 391     $name = substr( $name, 0, $max_id_length )
 392                         if ((length( $name ) > $max_id_length) && $critical);
 393     $scope->{ $name }++;
 394     return $name;
 395 }
 396
 397 sub unreserve {
 398     my $name            = shift || '';
 399     my $schema_obj_name = shift || '';
 400     my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
 401
 402     # also trap fields that don't begin with a letter
 403     return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
 404
 405     if ( $schema_obj_name ) {
 406         ++$unreserve{"$schema_obj_name.$name"};
 407     }
 408     else {
 409         ++$unreserve{"$name (table name)"};
 410     }
 411
 412     my $unreserve = sprintf '%s_', $name;
 413     return $unreserve.$suffix;
 414 }
 415
 416 1;
 417
 418 =pod
 419
 420 =head1 SEE ALSO
 421
 422 SQL::Translator.
 423
 424 =head1 AUTHORS
 425
 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>.
 429
 430 =cut