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