lib/SQL/Translator/Producer/Sybase.pm

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