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.60';
  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     $output .= header_comment unless ($no_comments);
 128
 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) || '';
 133
 134         my ( @comments, @field_defs, @index_defs, @constraint_defs );
 135
 136         push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;
 137
 138         push @comments, map { "-- $_" } $table->comments;
 139
 140         #
 141         # Fields
 142         #
 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
 147             );
 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/;
 153             }
 154
 155             #
 156             # Datatype
 157             #
 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 );
 164             my $seq_name;
 165
 166             my $identity = '';
 167
 168             if ( $data_type eq 'enum' ) {
 169                 my $check_name = mk_name(
 170                     $table_name.'_'.$field_name, 'chk' ,undef, 1
 171                 );
 172                 push @constraint_defs,
 173                 "CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
 174                 $data_type .= 'character varying';
 175             }
 176             elsif ( $data_type eq 'set' ) {
 177                 $data_type .= 'character varying';
 178             }
 179             else {
 180                 if ( $field->is_auto_increment ) {
 181                     $identity = 'IDENTITY';
 182                 }
 183                 if ( defined $translate{ $data_type } ) {
 184                     $data_type = $translate{ $data_type };
 185                 }
 186                 else {
 187                     warn "Unknown datatype: $data_type ",
 188                         "($table_name.$field_name)\n" if $WARN;
 189                 }
 190             }
 191
 192             my $size = $field->size;
 193             unless ( $size ) {
 194                 if ( $data_type =~ /numeric/ ) {
 195                     $size = '9,0';
 196                 }
 197                 elsif ( $orig_data_type eq 'text' ) {
 198                     #interpret text fields as long varchars
 199                     $size = '255';
 200                 }
 201                 elsif (
 202                     $data_type eq 'varchar' &&
 203                     $orig_data_type eq 'boolean'
 204                 ) {
 205                     $size = '6';
 206                 }
 207                 elsif ( $data_type eq 'varchar' ) {
 208                     $size = '255';
 209                 }
 210             }
 211
 212             $field_def .= " $data_type";
 213             $field_def .= "($size)" if $size;
 214             $field_def .= " $identity" if $identity;
 215
 216             #
 217             # Default value
 218             #
 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'"
 225                 );
 226             }
 227
 228             #
 229             # Not null constraint
 230             #
 231             unless ( $field->is_nullable ) {
 232                 $field_def .= ' NOT NULL';
 233             }
 234             else {
 235                 $field_def .= ' NULL' if $data_type ne 'bit';
 236             }
 237
 238             push @field_defs, $field_def;
 239         }
 240
 241         #
 242         # Constraint Declarations
 243         #
 244         my @constraint_decs = ();
 245         my $c_name_default;
 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 ) }
 250                 $constraint->fields;
 251             my @rfields = map { unreserve( $_, $table_name ) }
 252                 $constraint->reference_fields;
 253             next unless @fields;
 254
 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 ) . ')';
 260             }
 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 ) . ')';
 268             }
 269             elsif ( $type eq UNIQUE ) {
 270                 $name ||= mk_name(
 271                     $table_name,
 272                     $name || ++$c_name_default,undef, 1
 273                 );
 274                 push @constraint_defs,
 275                     "CONSTRAINT $name UNIQUE " .
 276                     '(' . join( ', ', @fields ) . ')';
 277             }
 278         }
 279
 280         #
 281         # Indices
 282         #
 283         for my $index ( $table->get_indices ) {
 284             push @index_defs,
 285                 'CREATE INDEX ' . $index->name .
 286                 " ON $table_name (".
 287                 join( ', ', $index->fields ) . ");";
 288         }
 289
 290         my $create_statement;
 291         $create_statement  = qq[DROP TABLE $table_name_ur;\n]
 292             if $add_drop_table;
 293         $create_statement .= qq[CREATE TABLE $table_name_ur (\n].
 294             join( ",\n",
 295                 map { "  $_" } @field_defs, @constraint_defs
 296             ).
 297             "\n);"
 298         ;
 299
 300         $output .= join( "\n\n",
 301             @comments,
 302             $create_statement,
 303             @index_defs,
 304             ''
 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         $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         $output .= join("\n\n",
 337                        @comments,
 338                        $procedure->sql(),
 339                        );
 340     }
 341
 342     if ( $WARN ) {
 343         if ( %truncated ) {
 344             warn "Truncated " . keys( %truncated ) . " names:\n";
 345             warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
 346         }
 347
 348         if ( %unreserve ) {
 349             warn "Encounted " . keys( %unreserve ) .
 350                 " unsafe names in schema (reserved or invalid):\n";
 351             warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
 352         }
 353     }
 354
 355     return $output;
 356 }
 357
 358 sub mk_name {
 359     my $basename      = shift || '';
 360     my $type          = shift || '';
 361     my $scope         = shift || '';
 362     my $critical      = shift || '';
 363     my $basename_orig = $basename;
 364     my $max_name      = $type
 365                         ? $max_id_length - (length($type) + 1)
 366                         : $max_id_length;
 367     $basename         = substr( $basename, 0, $max_name )
 368                         if length( $basename ) > $max_name;
 369     my $name          = $type ? "${type}_$basename" : $basename;
 370
 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;
 376     }
 377
 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;
 384
 385         warn "The name '$name_orig' has been changed to ",
 386              "'$name' to make it unique.\n" if $WARN;
 387
 388         $scope->{ $name_orig }++;
 389     }
 390     $name = substr( $name, 0, $max_id_length )
 391                         if ((length( $name ) > $max_id_length) && $critical);
 392     $scope->{ $name }++;
 393     return $name;
 394 }
 395
 396 sub unreserve {
 397     my $name            = shift || '';
 398     my $schema_obj_name = shift || '';
 399     my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
 400
 401     # also trap fields that don't begin with a letter
 402     return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
 403
 404     if ( $schema_obj_name ) {
 405         ++$unreserve{"$schema_obj_name.$name"};
 406     }
 407     else {
 408         ++$unreserve{"$name (table name)"};
 409     }
 410
 411     my $unreserve = sprintf '%s_', $name;
 412     return $unreserve.$suffix;
 413 }
 414
 415 1;
 416
 417 =pod
 418
 419 =head1 SEE ALSO
 420
 421 SQL::Translator.
 422
 423 =head1 AUTHORS
 424
 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>.
 428
 429 =cut