lib/SQL/Translator/Producer/Sybase.pm

   1 package SQL::Translator::Producer::Sybase;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: Sybase.pm,v 1.1 2003-05-12 14:29:51 angiuoli 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 #
  10 # This program is free software; you can redistribute it and/or
  11 # modify it under the terms of the GNU General Public License as
  12 # published by the Free Software Foundation; version 2.
  13 #
  14 # This program is distributed in the hope that it will be useful, but
  15 # WITHOUT ANY WARRANTY; without even the implied warranty of
  16 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  17 # General Public License for more details.
  18 #
  19 # You should have received a copy of the GNU General Public License
  20 # along with this program; if not, write to the Free Software
  21 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
  22 # 02111-1307  USA
  23 # -------------------------------------------------------------------
  24
  25 =head1 NAME
  26
  27 SQL::Translator::Producer::Sybase - Sybase producer for SQL::Translator
  28
  29 =cut
  30
  31 use strict;
  32 use vars qw[ $DEBUG $WARN $VERSION ];
  33 $VERSION = sprintf "%d.%02d", q$Revision: 1.1 $ =~ /(\d+)\.(\d+)/;
  34 $DEBUG = 1 unless defined $DEBUG;
  35
  36 use Data::Dumper;
  37
  38 my %translate  = (
  39     #
  40     # Sybase types
  41     #
  42     integer        => 'numeric',
  43     money      => 'money',
  44     varchar    => 'varchar',
  45     timestamp   => 'datetime',
  46     text       => 'varchar',
  47     real       => 'double precision',
  48     comment    => 'text',
  49     bit        => 'bit',
  50     tinyint    => 'smallint',
  51     float      => 'double precision',
  52     serial     => 'numeric',
  53     boolean    => 'varchar',
  54     char  => 'char'
  55
  56 );
  57
  58 my %reserved = map { $_, 1 } qw[
  59     ALL ANALYSE ANALYZE AND ANY AS ASC
  60     BETWEEN BINARY BOTH
  61     CASE CAST CHECK COLLATE COLUMN CONSTRAINT CROSS
  62     CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP CURRENT_USER
  63     DEFAULT DEFERRABLE DESC DISTINCT DO
  64     ELSE END EXCEPT
  65     FALSE FOR FOREIGN FREEZE FROM FULL
  66     GROUP HAVING
  67     ILIKE IN INITIALLY INNER INTERSECT INTO IS ISNULL
  68     JOIN LEADING LEFT LIKE LIMIT
  69     NATURAL NEW NOT NOTNULL NULL
  70     OFF OFFSET OLD ON ONLY OR ORDER OUTER OVERLAPS
  71     PRIMARY PUBLIC REFERENCES RIGHT
  72     SELECT SESSION_USER SOME TABLE THEN TO TRAILING TRUE
  73     UNION UNIQUE USER USING VERBOSE WHEN WHERE
  74 ];
  75
  76 my $max_id_length    = 30;
  77 my %used_identifiers = ();
  78 my %global_names;
  79 my %unreserve;
  80 my %truncated;
  81
  82 =pod
  83
  84 =head1 Sybase Create Table Syntax
  85
  86   CREATE [ [ LOCAL ] { TEMPORARY | TEMP } ] TABLE table_name (
  87       { column_name data_type [ DEFAULT default_expr ] [ column_constraint [, ... ] ]
  88       | table_constraint }  [, ... ]
  89   )
  90   [ INHERITS ( parent_table [, ... ] ) ]
  91   [ WITH OIDS | WITHOUT OIDS ]
  92
  93 where column_constraint is:
  94
  95   [ CONSTRAINT constraint_name ]
  96   { NOT NULL | NULL | UNIQUE | PRIMARY KEY |
  97     CHECK (expression) |
  98     REFERENCES reftable [ ( refcolumn ) ] [ MATCH FULL | MATCH PARTIAL ]
  99       [ ON DELETE action ] [ ON UPDATE action ] }
 100   [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
 101
 102 and table_constraint is:
 103
 104   [ CONSTRAINT constraint_name ]
 105   { UNIQUE ( column_name [, ... ] ) |
 106     PRIMARY KEY ( column_name [, ... ] ) |
 107     CHECK ( expression ) |
 108     FOREIGN KEY ( column_name [, ... ] ) REFERENCES reftable [ ( refcolumn [, ... ] ) ]
 109       [ MATCH FULL | MATCH PARTIAL ] [ ON DELETE action ] [ ON UPDATE action ] }
 110   [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
 111
 112 =head1 Create Index Syntax
 113
 114   CREATE [ UNIQUE ] INDEX index_name ON table
 115       [ USING acc_method ] ( column [ ops_name ] [, ...] )
 116       [ WHERE predicate ]
 117   CREATE [ UNIQUE ] INDEX index_name ON table
 118       [ USING acc_method ] ( func_name( column [, ... ]) [ ops_name ] )
 119       [ WHERE predicate ]
 120
 121 =cut
 122
 123 # -------------------------------------------------------------------
 124 sub produce {
 125     my ( $translator, $data ) = @_;
 126     $DEBUG                    = $translator->debug;
 127     $WARN                     = $translator->show_warnings;
 128     my $no_comments           = $translator->no_comments;
 129     my $add_drop_table        = $translator->add_drop_table;
 130
 131     my $output;
 132     unless ( $no_comments ) {
 133         $output .=  sprintf
 134             "--\n-- Created by %s\n-- Created on %s\n--\n\n",
 135             __PACKAGE__, scalar localtime;
 136     }
 137
 138     for my $table (
 139         map  { $_->[1] }
 140         sort { $a->[0] <=> $b->[0] }
 141         map  { [ $_->{'order'}, $_ ] }
 142         values %$data
 143    ) {
 144         my $table_name    = $table->{'table_name'};
 145         $table_name       = mk_name( $table_name, '', undef, 1 );
 146         my $table_name_ur = unreserve($table_name);
 147
 148         my ( @comments, @field_decs, @sequence_decs, @constraints );
 149
 150         push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;
 151
 152         #
 153         # Fields
 154         #
 155         my %field_name_scope;
 156         for my $field (
 157             map  { $_->[1] }
 158             sort { $a->[0] <=> $b->[0] }
 159             map  { [ $_->{'order'}, $_ ] }
 160             values %{ $table->{'fields'} }
 161         ) {
 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_str     = qq["$field_name_ur"];
 167             $field_str =~ s/\"//g;
 168             if ($field_str =~ /identity/){
 169                 $field_str =~ 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 $list      = $field->{'list'} || [];
 178             my $commalist = join ",", @$list;
 179             my $seq_name;
 180
 181             if ( $data_type eq 'enum' ) {
 182                 my $len = 0;
 183                 $len = ($len < length($_)) ? length($_) : $len for (@$list);
 184                 my $check_name = mk_name( $table_name.'_'.$field_name, 'chk' ,undef,1);
 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                 if( $orig_data_type eq 'text'){
 211                     #interpret text fields as long varchars
 212                     $field_str .= '(255)';
 213                 }
 214                 elsif($data_type eq "varchar" && $orig_data_type eq "boolean"){
 215                     $field_str .= '(6)';
 216                 }
 217                 elsif($data_type eq "varchar" && (!$field->{'size'})){
 218                     $field_str .= '(255)';
 219                 }
 220             }
 221
 222
 223             #
 224             # Default value
 225             #
 226             if ( defined $field->{'default'} ) {
 227                 $field_str .= sprintf( ' DEFAULT %s',
 228                     ( $field->{'is_auto_inc'} && $seq_name )
 229                     ? qq[nextval('"$seq_name"'::text)] :
 230                     ( $field->{'default'} =~ m/null/i )
 231                     ? 'NULL' :
 232                     "'".$field->{'default'}."'"
 233                 );
 234             }
 235
 236             #
 237             # Not null constraint
 238             #
 239             unless ( $field->{'null'} ) {
 240                 my $constraint_name = mk_name($field_name_ur, 'nn',undef,1);
 241 #                $field_str .= ' CONSTRAINT '.$constraint_name.' NOT NULL';
 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, 'CONSTRAINT '.$constraint_name.' PRIMARY KEY '.
 266                     '(' . join( ', ', @fields ) . ')';
 267             }
 268             if ( $constraint_type eq 'foreign_key' ) {
 269                 $constraint_name = mk_name( $table_name, 'fk',undef,1 );
 270                 push @constraints, 'CONSTRAINT '.$constraint_name.' FOREIGN KEY '.
 271                     '(' . join( ', ', @fields ) . ') '.
 272                     "REFERENCES $constraint->{'reference_table'}($constraint->{'reference_fields'}[0])";
 273             }
 274             elsif ( $constraint_type eq 'unique' ) {
 275                 $constraint_name = mk_name(
 276                     $table_name, $constraint_name || ++$idx_name_default,undef, 1
 277                 );
 278                 push @constraints, 'CONSTRAINT ' . $constraint_name . ' UNIQUE ' .
 279                     '(' . join( ', ', @fields ) . ')';
 280             }
 281             elsif ( $constraint_type eq 'normal' ) {
 282                 $constraint_name = mk_name(
 283                     $table_name, $constraint_name || ++$idx_name_default, undef, 1
 284                 );
 285                 push @constraint_decs,
 286                     qq[CREATE CONSTRAINT "$constraint_name" on $table_name_ur (].
 287                         join( ', ', @fields ).
 288                     ');';
 289             }
 290             else {
 291                 warn "Unknown constraint type ($constraint_type) on table $table_name.\n"
 292                     if $WARN;
 293             }
 294         }
 295
 296         my $create_statement;
 297         $create_statement  = qq[DROP TABLE $table_name_ur;\n]
 298             if $add_drop_table;
 299         $create_statement .= qq[CREATE TABLE $table_name_ur (\n].
 300             join( ",\n", map { "  $_" } @field_decs, @constraints ).
 301             "\n);"
 302         ;
 303
 304         $output .= join( "\n\n",
 305             @comments,
 306             @sequence_decs,
 307             $create_statement,
 308             @constraint_decs,
 309             ''
 310         );
 311                             }
 312 #
 313             # Index Declarations
 314             #
 315             for my $table (
 316                             map  { $_->[1] }
 317                             sort { $a->[0] <=> $b->[0] }
 318                             map  { [ $_->{'order'}, $_ ] }
 319                             values %$data
 320                             ) {
 321                 my $table_name    = $table->{'table_name'};
 322                 $table_name       = mk_name( $table_name, '', undef, 1 );
 323                 my $table_name_ur = unreserve($table_name);
 324
 325                 my @index_decs = ();
 326                 for my $index ( @{ $table->{'indices'} } ) {
 327                     my $unique = ($index->{'name'} eq 'unique') ? 'unique' : '';
 328                     $output .= "CREATE $unique INDEX $index->{'name'} ON $table->{'table_name'} (".join(',',@{$index->{'fields'}}).");\n";
 329                 }
 330             }
 331     if ( $WARN ) {
 332         if ( %truncated ) {
 333             warn "Truncated " . keys( %truncated ) . " names:\n";
 334             warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
 335         }
 336
 337         if ( %unreserve ) {
 338             warn "Encounted " . keys( %unreserve ) .
 339                 " unsafe names in schema (reserved or invalid):\n";
 340             warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
 341         }
 342     }
 343
 344     return $output;
 345 }
 346
 347 # -------------------------------------------------------------------
 348 sub mk_name {
 349     my ($basename, $type, $scope, $critical) = @_;
 350     my $basename_orig = $basename;
 351     my $max_name      = $type
 352                         ? $max_id_length - (length($type) + 1)
 353                         : $max_id_length;
 354     $basename         = substr( $basename, 0, $max_name )
 355                         if length( $basename ) > $max_name;
 356     my $name          = $type ? "${type}_$basename" : $basename;
 357     if ( $basename ne $basename_orig and $critical ) {
 358         my $show_type = $type ? "+'$type'" : "";
 359         warn "Truncating '$basename_orig'$show_type to $max_id_length ",
 360             "character limit to make '$name'\n" if $WARN;
 361         $truncated{ $basename_orig } = $name;
 362     }
 363
 364     $scope ||= \%global_names;
 365     if ( my $prev = $scope->{ $name } ) {
 366         my $name_orig = $name;
 367         $name        .= sprintf( "%02d", ++$prev );
 368         substr($name, $max_id_length - 3) = "00"
 369             if length( $name ) > $max_id_length;
 370
 371         warn "The name '$name_orig' has been changed to ",
 372              "'$name' to make it unique.\n" if $WARN;
 373
 374         $scope->{ $name_orig }++;
 375     }
 376     $name = substr( $name, 0, $max_id_length )
 377                         if ((length( $name ) > $max_id_length) && $critical);
 378     $scope->{ $name }++;
 379     return $name;
 380 }
 381
 382 # -------------------------------------------------------------------
 383 sub unreserve {
 384     my ( $name, $schema_obj_name ) = @_;
 385     my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
 386
 387     # also trap fields that don't begin with a letter
 388     return $_[0] if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
 389
 390     if ( $schema_obj_name ) {
 391         ++$unreserve{"$schema_obj_name.$name"};
 392     }
 393     else {
 394         ++$unreserve{"$name (table name)"};
 395     }
 396
 397     my $unreserve = sprintf '%s_', $name;
 398     return $unreserve.$suffix;
 399 }
 400
 401 1;
 402
 403 # -------------------------------------------------------------------
 404 # Life is full of misery, loneliness, and suffering --
 405 # and it's all over much too soon.
 406 # Woody Allen
 407 # -------------------------------------------------------------------
 408
 409 =pod
 410
 411 =head1 AUTHOR
 412
 413 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>
 414
 415 =cut