lib/SQL/Translator/Producer/Sybase.pm

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