lib/SQL/Translator/Producer/Sybase.pm

   1 package SQL::Translator::Producer::Sybase;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: Sybase.pm,v 1.7 2003-10-04 00:06:39 phrrngtn 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.7 $ =~ /(\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     foreach my $view ( $schema->get_views ) {
 318         my (@comments, $view_name);
 319
 320         $view_name = $view->name();
 321         push @comments, "--\n-- View: $view_name\n--" unless $no_comments;
 322
 323         # text of view is already a 'create view' statement so no need
 324         # to do anything fancy.
 325
 326         $output .= join("\n\n",
 327                        @comments,
 328                        $view->sql(),
 329                        );
 330     }
 331
 332
 333     foreach my $procedure ( $schema->get_procedures ) {
 334         my (@comments, $procedure_name);
 335
 336         $procedure_name = $procedure->name();
 337         push @comments, "--\n-- Procedure: $procedure_name\n--" unless $no_comments;
 338
 339         # text of procedure  already has the 'create procedure' stuff so there
 340         # is no need to do anything fancy. However, we should think about doing fancy stuff
 341         # with granting permissions and so on.
 342
 343         $output .= join("\n\n",
 344                        @comments,
 345                        $procedure->sql(),
 346                        );
 347     }
 348
 349     if ( $WARN ) {
 350         if ( %truncated ) {
 351             warn "Truncated " . keys( %truncated ) . " names:\n";
 352             warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
 353         }
 354
 355         if ( %unreserve ) {
 356             warn "Encounted " . keys( %unreserve ) .
 357                 " unsafe names in schema (reserved or invalid):\n";
 358             warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
 359         }
 360     }
 361
 362     return $output;
 363 }
 364
 365 # -------------------------------------------------------------------
 366 sub mk_name {
 367     my $basename      = shift || '';
 368     my $type          = shift || '';
 369     my $scope         = shift || '';
 370     my $critical      = shift || '';
 371     my $basename_orig = $basename;
 372     my $max_name      = $type
 373                         ? $max_id_length - (length($type) + 1)
 374                         : $max_id_length;
 375     $basename         = substr( $basename, 0, $max_name )
 376                         if length( $basename ) > $max_name;
 377     my $name          = $type ? "${type}_$basename" : $basename;
 378
 379     if ( $basename ne $basename_orig and $critical ) {
 380         my $show_type = $type ? "+'$type'" : "";
 381         warn "Truncating '$basename_orig'$show_type to $max_id_length ",
 382             "character limit to make '$name'\n" if $WARN;
 383         $truncated{ $basename_orig } = $name;
 384     }
 385
 386     $scope ||= \%global_names;
 387     if ( my $prev = $scope->{ $name } ) {
 388         my $name_orig = $name;
 389         $name        .= sprintf( "%02d", ++$prev );
 390         substr($name, $max_id_length - 3) = "00"
 391             if length( $name ) > $max_id_length;
 392
 393         warn "The name '$name_orig' has been changed to ",
 394              "'$name' to make it unique.\n" if $WARN;
 395
 396         $scope->{ $name_orig }++;
 397     }
 398     $name = substr( $name, 0, $max_id_length )
 399                         if ((length( $name ) > $max_id_length) && $critical);
 400     $scope->{ $name }++;
 401     return $name;
 402 }
 403
 404 # -------------------------------------------------------------------
 405 sub unreserve {
 406     my $name            = shift || '';
 407     my $schema_obj_name = shift || '';
 408     my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
 409
 410     # also trap fields that don't begin with a letter
 411     return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
 412
 413     if ( $schema_obj_name ) {
 414         ++$unreserve{"$schema_obj_name.$name"};
 415     }
 416     else {
 417         ++$unreserve{"$name (table name)"};
 418     }
 419
 420     my $unreserve = sprintf '%s_', $name;
 421     return $unreserve.$suffix;
 422 }
 423
 424 1;
 425
 426 # -------------------------------------------------------------------
 427
 428 =pod
 429
 430 =head1 AUTHORS
 431
 432 Sam Angiuoli E<lt>angiuoli@users.sourceforge.netE<gt>,
 433 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>
 434
 435 =cut