lib/SQL/Translator/Producer/Sybase.pm

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