lib/SQL/Translator/Producer/Sybase.pm

   1 package SQL::Translator::Producer::Sybase;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: Sybase.pm,v 1.3 2003-06-09 02:00:41 kycl4rk Exp $
   5 # -------------------------------------------------------------------
   6 # Copyright (C) 2003 Ken Y. Clark <kclark@cpan.org>,
   7 #                    darren chamberlain <darren@cpan.org>,
   8 #                    Chris Mungall <cjm@fruitfly.org>,
   9 #                    Sam Angiuoli <angiuoli@users.sourceforge.net>
  10 #
  11 # This program is free software; you can redistribute it and/or
  12 # modify it under the terms of the GNU General Public License as
  13 # published by the Free Software Foundation; version 2.
  14 #
  15 # This program is distributed in the hope that it will be useful, but
  16 # WITHOUT ANY WARRANTY; without even the implied warranty of
  17 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18 # General Public License for more details.
  19 #
  20 # You should have received a copy of the GNU General Public License
  21 # along with this program; if not, write to the Free Software
  22 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
  23 # 02111-1307  USA
  24 # -------------------------------------------------------------------
  25
  26 =head1 NAME
  27
  28 SQL::Translator::Producer::Sybase - Sybase producer for SQL::Translator
  29
  30 =cut
  31
  32 use strict;
  33 use vars qw[ $DEBUG $WARN $VERSION ];
  34 $VERSION = sprintf "%d.%02d", q$Revision: 1.3 $ =~ /(\d+)\.(\d+)/;
  35 $DEBUG = 1 unless defined $DEBUG;
  36
  37 use Data::Dumper;
  38 use SQL::Translator::Schema::Constants;
  39 use SQL::Translator::Utils qw(debug header_comment);
  40
  41 my %translate  = (
  42     #
  43     # Sybase types
  44     #
  45     integer   => 'numeric',
  46     int       => 'numeric',
  47     number    => 'numeric',
  48     money     => 'money',
  49     varchar   => 'varchar',
  50     varchar2  => 'varchar',
  51     timestamp => 'datetime',
  52     text      => 'varchar',
  53     real      => 'double precision',
  54     comment   => 'text',
  55     bit       => 'bit',
  56     tinyint   => 'smallint',
  57     float     => 'double precision',
  58     serial    => 'numeric',
  59     boolean   => 'varchar',
  60     char      => 'char',
  61     long      => 'varchar',
  62 );
  63
  64 my %reserved = map { $_, 1 } qw[
  65     ALL ANALYSE ANALYZE AND ANY AS ASC
  66     BETWEEN BINARY BOTH
  67     CASE CAST CHECK COLLATE COLUMN CONSTRAINT CROSS
  68     CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP CURRENT_USER
  69     DEFAULT DEFERRABLE DESC DISTINCT DO
  70     ELSE END EXCEPT
  71     FALSE FOR FOREIGN FREEZE FROM FULL
  72     GROUP HAVING
  73     ILIKE IN INITIALLY INNER INTERSECT INTO IS ISNULL
  74     JOIN LEADING LEFT LIKE LIMIT
  75     NATURAL NEW NOT NOTNULL NULL
  76     OFF OFFSET OLD ON ONLY OR ORDER OUTER OVERLAPS
  77     PRIMARY PUBLIC REFERENCES RIGHT
  78     SELECT SESSION_USER SOME TABLE THEN TO TRAILING TRUE
  79     UNION UNIQUE USER USING VERBOSE WHEN WHERE
  80 ];
  81
  82 my $max_id_length    = 30;
  83 my %used_identifiers = ();
  84 my %global_names;
  85 my %unreserve;
  86 my %truncated;
  87
  88 =pod
  89
  90 =head1 Sybase Create Table Syntax
  91
  92   CREATE [ [ LOCAL ] { TEMPORARY | TEMP } ] TABLE table_name (
  93       { column_name data_type [ DEFAULT default_expr ] [ column_constraint [, ... ] ]
  94       | table_constraint }  [, ... ]
  95   )
  96   [ INHERITS ( parent_table [, ... ] ) ]
  97   [ WITH OIDS | WITHOUT OIDS ]
  98
  99 where column_constraint is:
 100
 101   [ CONSTRAINT constraint_name ]
 102   { NOT NULL | NULL | UNIQUE | PRIMARY KEY |
 103     CHECK (expression) |
 104     REFERENCES reftable [ ( refcolumn ) ] [ MATCH FULL | MATCH PARTIAL ]
 105       [ ON DELETE action ] [ ON UPDATE action ] }
 106   [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
 107
 108 and table_constraint is:
 109
 110   [ CONSTRAINT constraint_name ]
 111   { UNIQUE ( column_name [, ... ] ) |
 112     PRIMARY KEY ( column_name [, ... ] ) |
 113     CHECK ( expression ) |
 114     FOREIGN KEY ( column_name [, ... ] ) REFERENCES reftable [ ( refcolumn [, ... ] ) ]
 115       [ MATCH FULL | MATCH PARTIAL ] [ ON DELETE action ] [ ON UPDATE action ] }
 116   [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
 117
 118 =head1 Create Index Syntax
 119
 120   CREATE [ UNIQUE ] INDEX index_name ON table
 121       [ USING acc_method ] ( column [ ops_name ] [, ...] )
 122       [ WHERE predicate ]
 123   CREATE [ UNIQUE ] INDEX index_name ON table
 124       [ USING acc_method ] ( func_name( column [, ... ]) [ ops_name ] )
 125       [ WHERE predicate ]
 126
 127 =cut
 128
 129 # -------------------------------------------------------------------
 130 sub produce {
 131     my ( $translator, $data ) = @_;
 132     $DEBUG                    = $translator->debug;
 133     $WARN                     = $translator->show_warnings;
 134     my $no_comments           = $translator->no_comments;
 135     my $add_drop_table        = $translator->add_drop_table;
 136     my $schema                = $translator->schema;
 137
 138     my $output;
 139     $output .= header_comment unless ($no_comments);
 140
 141     for my $table ( $schema->get_tables ) {
 142         my $table_name    = $table->name or next;
 143         $table_name       = mk_name( $table_name, '', undef, 1 );
 144         my $table_name_ur = unreserve($table_name) || '';
 145
 146         my ( @comments, @field_defs, @index_defs, @constraint_defs );
 147
 148         push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;
 149
 150         push @comments, map { "-- $_" } $table->comments;
 151
 152         #
 153         # Fields
 154         #
 155         my %field_name_scope;
 156         for my $field ( $table->get_fields ) {
 157             my $field_name    = mk_name(
 158                 $field->name, '', \%field_name_scope, undef,1
 159             );
 160             my $field_name_ur = unreserve( $field_name, $table_name );
 161             my $field_def     = qq["$field_name_ur"];
 162             $field_def        =~ s/\"//g;
 163             if ( $field_def =~ /identity/ ){
 164                 $field_def =~ s/identity/pidentity/;
 165             }
 166
 167             #
 168             # Datatype
 169             #
 170             my $data_type      = lc $field->data_type;
 171             my $orig_data_type = $data_type;
 172             my %extra          = $field->extra;
 173             my $list           = $extra{'list'} || [];
 174             my $commalist      = join ",", @$list;
 175             my $seq_name;
 176
 177             if ( $data_type eq 'enum' ) {
 178                 my $check_name = mk_name(
 179                     $table_name.'_'.$field_name, 'chk' ,undef, 1
 180                 );
 181                 push @constraint_defs,
 182                 "CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
 183                 $data_type .= 'character varying';
 184             }
 185             elsif ( $data_type eq 'set' ) {
 186                 $data_type .= 'character varying';
 187             }
 188             elsif ( $field->is_auto_increment ) {
 189                 $field_def .= ' IDENTITY';
 190             }
 191             else {
 192                 if ( defined $translate{ $data_type } ) {
 193                     $data_type = $translate{ $data_type };
 194                 }
 195                 else {
 196                     warn "Unknown datatype: $data_type ",
 197                         "($table_name.$field_name)\n" if $WARN;
 198                 }
 199             }
 200
 201             my $size = $field->size;
 202             unless ( $size ) {
 203                 if ( $data_type =~ /numeric/ ) {
 204                     $size = '9,0';
 205                 }
 206                 elsif ( $orig_data_type eq 'text' ) {
 207                     #interpret text fields as long varchars
 208                     $size = '255';
 209                 }
 210                 elsif (
 211                     $data_type eq 'varchar' &&
 212                     $orig_data_type eq 'boolean'
 213                 ) {
 214                     $size = '6';
 215                 }
 216                 elsif ( $data_type eq 'varchar' ) {
 217                     $size = '255';
 218                 }
 219             }
 220
 221             $field_def .= " $data_type";
 222             $field_def .= "($size)" if $size;
 223
 224             #
 225             # Default value
 226             #
 227             my $default = $field->default_value;
 228             if ( defined $default ) {
 229                 $field_def .= sprintf( ' DEFAULT %s',
 230                     ( $field->is_auto_increment && $seq_name )
 231                     ? qq[nextval('"$seq_name"'::text)] :
 232                     ( $default =~ m/null/i ) ? 'NULL' : "'$default'"
 233                 );
 234             }
 235
 236             #
 237             # Not null constraint
 238             #
 239             unless ( $field->is_nullable ) {
 240                 $field_def .= ' NOT NULL';
 241             }
 242             else {
 243                 $field_def .= ' NULL' if $data_type ne 'bit';
 244             }
 245
 246             push @field_defs, $field_def;
 247         }
 248
 249         #
 250         # Constraint Declarations
 251         #
 252         my @constraint_decs = ();
 253         my $c_name_default;
 254         for my $constraint ( $table->get_constraints ) {
 255             my $name    = $constraint->name || '';
 256             my $type    = $constraint->type || NORMAL;
 257             my @fields  = map { unreserve( $_, $table_name ) }
 258                 $constraint->fields;
 259             my @rfields = map { unreserve( $_, $table_name ) }
 260                 $constraint->reference_fields;
 261             next unless @fields;
 262
 263             if ( $type eq PRIMARY_KEY ) {
 264                 $name ||= mk_name( $table_name, 'pk', undef,1 );
 265                 push @constraint_defs,
 266                     "CONSTRAINT $name PRIMARY KEY ".
 267                     '(' . join( ', ', @fields ) . ')';
 268             }
 269             elsif ( $type eq FOREIGN_KEY ) {
 270                 $name ||= mk_name( $table_name, 'fk', undef,1 );
 271                 push @constraint_defs,
 272                     "CONSTRAINT $name FOREIGN KEY".
 273                     ' (' . join( ', ', @fields ) . ') REFERENCES '.
 274                     $constraint->reference_table.
 275                     ' (' . join( ', ', @rfields ) . ')';
 276             }
 277             elsif ( $type eq UNIQUE ) {
 278                 $name ||= mk_name(
 279                     $table_name,
 280                     $name || ++$c_name_default,undef, 1
 281                 );
 282                 push @constraint_defs,
 283                     "CONSTRAINT $name UNIQUE " .
 284                     '(' . join( ', ', @fields ) . ')';
 285             }
 286         }
 287
 288         #
 289         # Indices
 290         #
 291         for my $index ( $table->get_indices ) {
 292             push @index_defs,
 293                 'CREATE INDEX ' . $index->name .
 294                 " ON $table_name (".
 295                 join( ', ', $index->fields ) . ");";
 296         }
 297
 298         my $create_statement;
 299         $create_statement  = qq[DROP TABLE $table_name_ur;\n]
 300             if $add_drop_table;
 301         $create_statement .= qq[CREATE TABLE $table_name_ur (\n].
 302             join( ",\n",
 303                 map { "  $_" } @field_defs, @constraint_defs
 304             ).
 305             "\n);"
 306         ;
 307
 308         $output .= join( "\n\n",
 309             @comments,
 310             $create_statement,
 311             @index_defs,
 312             ''
 313         );
 314     }
 315
 316     if ( $WARN ) {
 317         if ( %truncated ) {
 318             warn "Truncated " . keys( %truncated ) . " names:\n";
 319             warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
 320         }
 321
 322         if ( %unreserve ) {
 323             warn "Encounted " . keys( %unreserve ) .
 324                 " unsafe names in schema (reserved or invalid):\n";
 325             warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
 326         }
 327     }
 328
 329     return $output;
 330 }
 331
 332 # -------------------------------------------------------------------
 333 sub mk_name {
 334     my $basename      = shift || '';
 335     my $type          = shift || '';
 336     my $scope         = shift || '';
 337     my $critical      = shift || '';
 338     my $basename_orig = $basename;
 339     my $max_name      = $type
 340                         ? $max_id_length - (length($type) + 1)
 341                         : $max_id_length;
 342     $basename         = substr( $basename, 0, $max_name )
 343                         if length( $basename ) > $max_name;
 344     my $name          = $type ? "${type}_$basename" : $basename;
 345
 346     if ( $basename ne $basename_orig and $critical ) {
 347         my $show_type = $type ? "+'$type'" : "";
 348         warn "Truncating '$basename_orig'$show_type to $max_id_length ",
 349             "character limit to make '$name'\n" if $WARN;
 350         $truncated{ $basename_orig } = $name;
 351     }
 352
 353     $scope ||= \%global_names;
 354     if ( my $prev = $scope->{ $name } ) {
 355         my $name_orig = $name;
 356         $name        .= sprintf( "%02d", ++$prev );
 357         substr($name, $max_id_length - 3) = "00"
 358             if length( $name ) > $max_id_length;
 359
 360         warn "The name '$name_orig' has been changed to ",
 361              "'$name' to make it unique.\n" if $WARN;
 362
 363         $scope->{ $name_orig }++;
 364     }
 365     $name = substr( $name, 0, $max_id_length )
 366                         if ((length( $name ) > $max_id_length) && $critical);
 367     $scope->{ $name }++;
 368     return $name;
 369 }
 370
 371 # -------------------------------------------------------------------
 372 sub unreserve {
 373     my $name            = shift || '';
 374     my $schema_obj_name = shift || '';
 375     my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
 376
 377     # also trap fields that don't begin with a letter
 378     return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
 379
 380     if ( $schema_obj_name ) {
 381         ++$unreserve{"$schema_obj_name.$name"};
 382     }
 383     else {
 384         ++$unreserve{"$name (table name)"};
 385     }
 386
 387     my $unreserve = sprintf '%s_', $name;
 388     return $unreserve.$suffix;
 389 }
 390
 391 1;
 392
 393 # -------------------------------------------------------------------
 394
 395 =pod
 396
 397 =head1 AUTHORS
 398
 399 Sam Angiuoli E<lt>angiuoli@users.sourceforge.netE<gt>,
 400 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>
 401
 402 =cut