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.59';
  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 sub produce {
 136     my $translator     = shift;
 137     $DEBUG             = $translator->debug;
 138     $WARN              = $translator->show_warnings;
 139     my $no_comments    = $translator->no_comments;
 140     my $add_drop_table = $translator->add_drop_table;
 141     my $schema         = $translator->schema;
 142
 143     my $output;
 144     $output .= header_comment unless ($no_comments);
 145
 146     for my $table ( $schema->get_tables ) {
 147         my $table_name    = $table->name or next;
 148         $table_name       = mk_name( $table_name, '', undef, 1 );
 149         my $table_name_ur = unreserve($table_name) || '';
 150
 151         my ( @comments, @field_defs, @index_defs, @constraint_defs );
 152
 153         push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;
 154
 155         push @comments, map { "-- $_" } $table->comments;
 156
 157         #
 158         # Fields
 159         #
 160         my %field_name_scope;
 161         for my $field ( $table->get_fields ) {
 162             my $field_name    = mk_name(
 163                 $field->name, '', \%field_name_scope, undef,1
 164             );
 165             my $field_name_ur = unreserve( $field_name, $table_name );
 166             my $field_def     = qq["$field_name_ur"];
 167             $field_def        =~ s/\"//g;
 168             if ( $field_def =~ /identity/ ){
 169                 $field_def =~ s/identity/pidentity/;
 170             }
 171
 172             #
 173             # Datatype
 174             #
 175             my $data_type      = lc $field->data_type;
 176             my $orig_data_type = $data_type;
 177             my %extra          = $field->extra;
 178             my $list           = $extra{'list'} || [];
 179             # \todo deal with embedded quotes
 180             my $commalist      = join( ', ', map { qq['$_'] } @$list );
 181             my $seq_name;
 182
 183             if ( $data_type eq 'enum' ) {
 184                 my $check_name = mk_name(
 185                     $table_name.'_'.$field_name, 'chk' ,undef, 1
 186                 );
 187                 push @constraint_defs,
 188                 "CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
 189                 $data_type .= 'character varying';
 190             }
 191             elsif ( $data_type eq 'set' ) {
 192                 $data_type .= 'character varying';
 193             }
 194             elsif ( $field->is_auto_increment ) {
 195                 $field_def .= ' IDENTITY';
 196             }
 197             else {
 198                 if ( defined $translate{ $data_type } ) {
 199                     $data_type = $translate{ $data_type };
 200                 }
 201                 else {
 202                     warn "Unknown datatype: $data_type ",
 203                         "($table_name.$field_name)\n" if $WARN;
 204                 }
 205             }
 206
 207             my $size = $field->size;
 208             unless ( $size ) {
 209                 if ( $data_type =~ /numeric/ ) {
 210                     $size = '9,0';
 211                 }
 212                 elsif ( $orig_data_type eq 'text' ) {
 213                     #interpret text fields as long varchars
 214                     $size = '255';
 215                 }
 216                 elsif (
 217                     $data_type eq 'varchar' &&
 218                     $orig_data_type eq 'boolean'
 219                 ) {
 220                     $size = '6';
 221                 }
 222                 elsif ( $data_type eq 'varchar' ) {
 223                     $size = '255';
 224                 }
 225             }
 226
 227             $field_def .= " $data_type";
 228             $field_def .= "($size)" if $size;
 229
 230             #
 231             # Default value
 232             #
 233             my $default = $field->default_value;
 234             if ( defined $default ) {
 235                 $field_def .= sprintf( ' DEFAULT %s',
 236                     ( $field->is_auto_increment && $seq_name )
 237                     ? qq[nextval('"$seq_name"'::text)] :
 238                     ( $default =~ m/null/i ) ? 'NULL' : "'$default'"
 239                 );
 240             }
 241
 242             #
 243             # Not null constraint
 244             #
 245             unless ( $field->is_nullable ) {
 246                 $field_def .= ' NOT NULL';
 247             }
 248             else {
 249                 $field_def .= ' NULL' if $data_type ne 'bit';
 250             }
 251
 252             push @field_defs, $field_def;
 253         }
 254
 255         #
 256         # Constraint Declarations
 257         #
 258         my @constraint_decs = ();
 259         my $c_name_default;
 260         for my $constraint ( $table->get_constraints ) {
 261             my $name    = $constraint->name || '';
 262             my $type    = $constraint->type || NORMAL;
 263             my @fields  = map { unreserve( $_, $table_name ) }
 264                 $constraint->fields;
 265             my @rfields = map { unreserve( $_, $table_name ) }
 266                 $constraint->reference_fields;
 267             next unless @fields;
 268
 269             if ( $type eq PRIMARY_KEY ) {
 270                 $name ||= mk_name( $table_name, 'pk', undef,1 );
 271                 push @constraint_defs,
 272                     "CONSTRAINT $name PRIMARY KEY ".
 273                     '(' . join( ', ', @fields ) . ')';
 274             }
 275             elsif ( $type eq FOREIGN_KEY ) {
 276                 $name ||= mk_name( $table_name, 'fk', undef,1 );
 277                 push @constraint_defs,
 278                     "CONSTRAINT $name FOREIGN KEY".
 279                     ' (' . join( ', ', @fields ) . ') REFERENCES '.
 280                     $constraint->reference_table.
 281                     ' (' . join( ', ', @rfields ) . ')';
 282             }
 283             elsif ( $type eq UNIQUE ) {
 284                 $name ||= mk_name(
 285                     $table_name,
 286                     $name || ++$c_name_default,undef, 1
 287                 );
 288                 push @constraint_defs,
 289                     "CONSTRAINT $name UNIQUE " .
 290                     '(' . join( ', ', @fields ) . ')';
 291             }
 292         }
 293
 294         #
 295         # Indices
 296         #
 297         for my $index ( $table->get_indices ) {
 298             push @index_defs,
 299                 'CREATE INDEX ' . $index->name .
 300                 " ON $table_name (".
 301                 join( ', ', $index->fields ) . ");";
 302         }
 303
 304         my $create_statement;
 305         $create_statement  = qq[DROP TABLE $table_name_ur;\n]
 306             if $add_drop_table;
 307         $create_statement .= qq[CREATE TABLE $table_name_ur (\n].
 308             join( ",\n",
 309                 map { "  $_" } @field_defs, @constraint_defs
 310             ).
 311             "\n);"
 312         ;
 313
 314         $output .= join( "\n\n",
 315             @comments,
 316             $create_statement,
 317             @index_defs,
 318             ''
 319         );
 320     }
 321
 322     foreach my $view ( $schema->get_views ) {
 323         my (@comments, $view_name);
 324
 325         $view_name = $view->name();
 326         push @comments, "--\n-- View: $view_name\n--" unless $no_comments;
 327
 328         # text of view is already a 'create view' statement so no need
 329         # to do anything fancy.
 330
 331         $output .= join("\n\n",
 332                        @comments,
 333                        $view->sql(),
 334                        );
 335     }
 336
 337
 338     foreach my $procedure ( $schema->get_procedures ) {
 339         my (@comments, $procedure_name);
 340
 341         $procedure_name = $procedure->name();
 342         push @comments,
 343             "--\n-- Procedure: $procedure_name\n--" unless $no_comments;
 344
 345         # text of procedure  already has the 'create procedure' stuff
 346         # so there is no need to do anything fancy. However, we should
 347         # think about doing fancy stuff with granting permissions and
 348         # so on.
 349
 350         $output .= join("\n\n",
 351                        @comments,
 352                        $procedure->sql(),
 353                        );
 354     }
 355
 356     if ( $WARN ) {
 357         if ( %truncated ) {
 358             warn "Truncated " . keys( %truncated ) . " names:\n";
 359             warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
 360         }
 361
 362         if ( %unreserve ) {
 363             warn "Encounted " . keys( %unreserve ) .
 364                 " unsafe names in schema (reserved or invalid):\n";
 365             warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
 366         }
 367     }
 368
 369     return $output;
 370 }
 371
 372 sub mk_name {
 373     my $basename      = shift || '';
 374     my $type          = shift || '';
 375     my $scope         = shift || '';
 376     my $critical      = shift || '';
 377     my $basename_orig = $basename;
 378     my $max_name      = $type
 379                         ? $max_id_length - (length($type) + 1)
 380                         : $max_id_length;
 381     $basename         = substr( $basename, 0, $max_name )
 382                         if length( $basename ) > $max_name;
 383     my $name          = $type ? "${type}_$basename" : $basename;
 384
 385     if ( $basename ne $basename_orig and $critical ) {
 386         my $show_type = $type ? "+'$type'" : "";
 387         warn "Truncating '$basename_orig'$show_type to $max_id_length ",
 388             "character limit to make '$name'\n" if $WARN;
 389         $truncated{ $basename_orig } = $name;
 390     }
 391
 392     $scope ||= \%global_names;
 393     if ( my $prev = $scope->{ $name } ) {
 394         my $name_orig = $name;
 395         $name        .= sprintf( "%02d", ++$prev );
 396         substr($name, $max_id_length - 3) = "00"
 397             if length( $name ) > $max_id_length;
 398
 399         warn "The name '$name_orig' has been changed to ",
 400              "'$name' to make it unique.\n" if $WARN;
 401
 402         $scope->{ $name_orig }++;
 403     }
 404     $name = substr( $name, 0, $max_id_length )
 405                         if ((length( $name ) > $max_id_length) && $critical);
 406     $scope->{ $name }++;
 407     return $name;
 408 }
 409
 410 sub unreserve {
 411     my $name            = shift || '';
 412     my $schema_obj_name = shift || '';
 413     my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
 414
 415     # also trap fields that don't begin with a letter
 416     return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
 417
 418     if ( $schema_obj_name ) {
 419         ++$unreserve{"$schema_obj_name.$name"};
 420     }
 421     else {
 422         ++$unreserve{"$name (table name)"};
 423     }
 424
 425     my $unreserve = sprintf '%s_', $name;
 426     return $unreserve.$suffix;
 427 }
 428
 429 1;
 430
 431 =pod
 432
 433 =head1 SEE ALSO
 434
 435 SQL::Translator.
 436
 437 =head1 AUTHORS
 438
 439 Sam Angiuoli E<lt>angiuoli@users.sourceforge.netE<gt>,
 440 Paul Harrington E<lt>harringp@deshaw.comE<gt>,
 441 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>.
 442
 443 =cut