lib/SQL/Translator/Producer/Sybase.pm

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