lib/SQL/Translator/Producer/Sybase.pm

   1 package SQL::Translator::Producer::Sybase;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: Sybase.pm,v 1.6 2003-08-18 15:43:15 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.6 $ =~ /(\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     = shift;
 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             # \todo deal with embedded quotes
 175             my $commalist      = join( ', ', map { qq['$_'] } @$list );
 176             my $seq_name;
 177
 178             if ( $data_type eq 'enum' ) {
 179                 my $check_name = mk_name(
 180                     $table_name.'_'.$field_name, 'chk' ,undef, 1
 181                 );
 182                 push @constraint_defs,
 183                 "CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
 184                 $data_type .= 'character varying';
 185             }
 186             elsif ( $data_type eq 'set' ) {
 187                 $data_type .= 'character varying';
 188             }
 189             elsif ( $field->is_auto_increment ) {
 190                 $field_def .= ' IDENTITY';
 191             }
 192             else {
 193                 if ( defined $translate{ $data_type } ) {
 194                     $data_type = $translate{ $data_type };
 195                 }
 196                 else {
 197                     warn "Unknown datatype: $data_type ",
 198                         "($table_name.$field_name)\n" if $WARN;
 199                 }
 200             }
 201
 202             my $size = $field->size;
 203             unless ( $size ) {
 204                 if ( $data_type =~ /numeric/ ) {
 205                     $size = '9,0';
 206                 }
 207                 elsif ( $orig_data_type eq 'text' ) {
 208                     #interpret text fields as long varchars
 209                     $size = '255';
 210                 }
 211                 elsif (
 212                     $data_type eq 'varchar' &&
 213                     $orig_data_type eq 'boolean'
 214                 ) {
 215                     $size = '6';
 216                 }
 217                 elsif ( $data_type eq 'varchar' ) {
 218                     $size = '255';
 219                 }
 220             }
 221
 222             $field_def .= " $data_type";
 223             $field_def .= "($size)" if $size;
 224
 225             #
 226             # Default value
 227             #
 228             my $default = $field->default_value;
 229             if ( defined $default ) {
 230                 $field_def .= sprintf( ' DEFAULT %s',
 231                     ( $field->is_auto_increment && $seq_name )
 232                     ? qq[nextval('"$seq_name"'::text)] :
 233                     ( $default =~ m/null/i ) ? 'NULL' : "'$default'"
 234                 );
 235             }
 236
 237             #
 238             # Not null constraint
 239             #
 240             unless ( $field->is_nullable ) {
 241                 $field_def .= ' NOT NULL';
 242             }
 243             else {
 244                 $field_def .= ' NULL' if $data_type ne 'bit';
 245             }
 246
 247             push @field_defs, $field_def;
 248         }
 249
 250         #
 251         # Constraint Declarations
 252         #
 253         my @constraint_decs = ();
 254         my $c_name_default;
 255         for my $constraint ( $table->get_constraints ) {
 256             my $name    = $constraint->name || '';
 257             my $type    = $constraint->type || NORMAL;
 258             my @fields  = map { unreserve( $_, $table_name ) }
 259                 $constraint->fields;
 260             my @rfields = map { unreserve( $_, $table_name ) }
 261                 $constraint->reference_fields;
 262             next unless @fields;
 263
 264             if ( $type eq PRIMARY_KEY ) {
 265                 $name ||= mk_name( $table_name, 'pk', undef,1 );
 266                 push @constraint_defs,
 267                     "CONSTRAINT $name PRIMARY KEY ".
 268                     '(' . join( ', ', @fields ) . ')';
 269             }
 270             elsif ( $type eq FOREIGN_KEY ) {
 271                 $name ||= mk_name( $table_name, 'fk', undef,1 );
 272                 push @constraint_defs,
 273                     "CONSTRAINT $name FOREIGN KEY".
 274                     ' (' . join( ', ', @fields ) . ') REFERENCES '.
 275                     $constraint->reference_table.
 276                     ' (' . join( ', ', @rfields ) . ')';
 277             }
 278             elsif ( $type eq UNIQUE ) {
 279                 $name ||= mk_name(
 280                     $table_name,
 281                     $name || ++$c_name_default,undef, 1
 282                 );
 283                 push @constraint_defs,
 284                     "CONSTRAINT $name UNIQUE " .
 285                     '(' . join( ', ', @fields ) . ')';
 286             }
 287         }
 288
 289         #
 290         # Indices
 291         #
 292         for my $index ( $table->get_indices ) {
 293             push @index_defs,
 294                 'CREATE INDEX ' . $index->name .
 295                 " ON $table_name (".
 296                 join( ', ', $index->fields ) . ");";
 297         }
 298
 299         my $create_statement;
 300         $create_statement  = qq[DROP TABLE $table_name_ur;\n]
 301             if $add_drop_table;
 302         $create_statement .= qq[CREATE TABLE $table_name_ur (\n].
 303             join( ",\n",
 304                 map { "  $_" } @field_defs, @constraint_defs
 305             ).
 306             "\n);"
 307         ;
 308
 309         $output .= join( "\n\n",
 310             @comments,
 311             $create_statement,
 312             @index_defs,
 313             ''
 314         );
 315     }
 316
 317     if ( $WARN ) {
 318         if ( %truncated ) {
 319             warn "Truncated " . keys( %truncated ) . " names:\n";
 320             warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
 321         }
 322
 323         if ( %unreserve ) {
 324             warn "Encounted " . keys( %unreserve ) .
 325                 " unsafe names in schema (reserved or invalid):\n";
 326             warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
 327         }
 328     }
 329
 330     return $output;
 331 }
 332
 333 # -------------------------------------------------------------------
 334 sub mk_name {
 335     my $basename      = shift || '';
 336     my $type          = shift || '';
 337     my $scope         = shift || '';
 338     my $critical      = shift || '';
 339     my $basename_orig = $basename;
 340     my $max_name      = $type
 341                         ? $max_id_length - (length($type) + 1)
 342                         : $max_id_length;
 343     $basename         = substr( $basename, 0, $max_name )
 344                         if length( $basename ) > $max_name;
 345     my $name          = $type ? "${type}_$basename" : $basename;
 346
 347     if ( $basename ne $basename_orig and $critical ) {
 348         my $show_type = $type ? "+'$type'" : "";
 349         warn "Truncating '$basename_orig'$show_type to $max_id_length ",
 350             "character limit to make '$name'\n" if $WARN;
 351         $truncated{ $basename_orig } = $name;
 352     }
 353
 354     $scope ||= \%global_names;
 355     if ( my $prev = $scope->{ $name } ) {
 356         my $name_orig = $name;
 357         $name        .= sprintf( "%02d", ++$prev );
 358         substr($name, $max_id_length - 3) = "00"
 359             if length( $name ) > $max_id_length;
 360
 361         warn "The name '$name_orig' has been changed to ",
 362              "'$name' to make it unique.\n" if $WARN;
 363
 364         $scope->{ $name_orig }++;
 365     }
 366     $name = substr( $name, 0, $max_id_length )
 367                         if ((length( $name ) > $max_id_length) && $critical);
 368     $scope->{ $name }++;
 369     return $name;
 370 }
 371
 372 # -------------------------------------------------------------------
 373 sub unreserve {
 374     my $name            = shift || '';
 375     my $schema_obj_name = shift || '';
 376     my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
 377
 378     # also trap fields that don't begin with a letter
 379     return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
 380
 381     if ( $schema_obj_name ) {
 382         ++$unreserve{"$schema_obj_name.$name"};
 383     }
 384     else {
 385         ++$unreserve{"$name (table name)"};
 386     }
 387
 388     my $unreserve = sprintf '%s_', $name;
 389     return $unreserve.$suffix;
 390 }
 391
 392 1;
 393
 394 # -------------------------------------------------------------------
 395
 396 =pod
 397
 398 =head1 AUTHORS
 399
 400 Sam Angiuoli E<lt>angiuoli@users.sourceforge.netE<gt>,
 401 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>
 402
 403 =cut