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 warnings;
  22 our ( $DEBUG, $WARN );
  23 our $VERSION = '1.59';
  24 $DEBUG = 1 unless defined $DEBUG;
  25
  26 use Data::Dumper;
  27 use SQL::Translator::Schema::Constants;
  28 use SQL::Translator::Utils qw(debug header_comment);
  29
  30 my %translate  = (
  31     #
  32     # Sybase types
  33     #
  34     integer   => 'numeric',
  35     int       => 'numeric',
  36     number    => 'numeric',
  37     money     => 'money',
  38     varchar   => 'varchar',
  39     varchar2  => 'varchar',
  40     timestamp => 'datetime',
  41     text      => 'varchar',
  42     real      => 'double precision',
  43     comment   => 'text',
  44     bit       => 'bit',
  45     tinyint   => 'smallint',
  46     float     => 'double precision',
  47     serial    => 'numeric',
  48     boolean   => 'varchar',
  49     char      => 'char',
  50     long      => 'varchar',
  51 );
  52
  53 my %reserved = map { $_, 1 } qw[
  54     ALL ANALYSE ANALYZE AND ANY AS ASC
  55     BETWEEN BINARY BOTH
  56     CASE CAST CHECK COLLATE COLUMN CONSTRAINT CROSS
  57     CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP CURRENT_USER
  58     DEFAULT DEFERRABLE DESC DISTINCT DO
  59     ELSE END EXCEPT
  60     FALSE FOR FOREIGN FREEZE FROM FULL
  61     GROUP HAVING
  62     ILIKE IN INITIALLY INNER INTERSECT INTO IS ISNULL
  63     JOIN LEADING LEFT LIKE LIMIT
  64     NATURAL NEW NOT NOTNULL NULL
  65     OFF OFFSET OLD ON ONLY OR ORDER OUTER OVERLAPS
  66     PRIMARY PUBLIC REFERENCES RIGHT
  67     SELECT SESSION_USER SOME TABLE THEN TO TRAILING TRUE
  68     UNION UNIQUE USER USING VERBOSE WHEN WHERE
  69 ];
  70
  71 my $max_id_length    = 30;
  72 my %used_identifiers = ();
  73 my %global_names;
  74 my %unreserve;
  75 my %truncated;
  76
  77 =pod
  78
  79 =head1 Sybase Create Table Syntax
  80
  81   CREATE [ [ LOCAL ] { TEMPORARY | TEMP } ] TABLE table_name (
  82       { column_name data_type [ DEFAULT default_expr ] [ column_constraint [, ... ] ]
  83       | table_constraint }  [, ... ]
  84   )
  85   [ INHERITS ( parent_table [, ... ] ) ]
  86   [ WITH OIDS | WITHOUT OIDS ]
  87
  88 where column_constraint is:
  89
  90   [ CONSTRAINT constraint_name ]
  91   { NOT NULL | NULL | UNIQUE | PRIMARY KEY |
  92     CHECK (expression) |
  93     REFERENCES reftable [ ( refcolumn ) ] [ MATCH FULL | MATCH PARTIAL ]
  94       [ ON DELETE action ] [ ON UPDATE action ] }
  95   [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
  96
  97 and table_constraint is:
  98
  99   [ CONSTRAINT constraint_name ]
 100   { UNIQUE ( column_name [, ... ] ) |
 101     PRIMARY KEY ( column_name [, ... ] ) |
 102     CHECK ( expression ) |
 103     FOREIGN KEY ( column_name [, ... ] ) REFERENCES reftable [ ( refcolumn [, ... ] ) ]
 104       [ MATCH FULL | MATCH PARTIAL ] [ ON DELETE action ] [ ON UPDATE action ] }
 105   [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
 106
 107 =head1 Create Index Syntax
 108
 109   CREATE [ UNIQUE ] INDEX index_name ON table
 110       [ USING acc_method ] ( column [ ops_name ] [, ...] )
 111       [ WHERE predicate ]
 112   CREATE [ UNIQUE ] INDEX index_name ON table
 113       [ USING acc_method ] ( func_name( column [, ... ]) [ ops_name ] )
 114       [ WHERE predicate ]
 115
 116 =cut
 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 sub mk_name {
 356     my $basename      = shift || '';
 357     my $type          = shift || '';
 358     my $scope         = shift || '';
 359     my $critical      = shift || '';
 360     my $basename_orig = $basename;
 361     my $max_name      = $type
 362                         ? $max_id_length - (length($type) + 1)
 363                         : $max_id_length;
 364     $basename         = substr( $basename, 0, $max_name )
 365                         if length( $basename ) > $max_name;
 366     my $name          = $type ? "${type}_$basename" : $basename;
 367
 368     if ( $basename ne $basename_orig and $critical ) {
 369         my $show_type = $type ? "+'$type'" : "";
 370         warn "Truncating '$basename_orig'$show_type to $max_id_length ",
 371             "character limit to make '$name'\n" if $WARN;
 372         $truncated{ $basename_orig } = $name;
 373     }
 374
 375     $scope ||= \%global_names;
 376     if ( my $prev = $scope->{ $name } ) {
 377         my $name_orig = $name;
 378         $name        .= sprintf( "%02d", ++$prev );
 379         substr($name, $max_id_length - 3) = "00"
 380             if length( $name ) > $max_id_length;
 381
 382         warn "The name '$name_orig' has been changed to ",
 383              "'$name' to make it unique.\n" if $WARN;
 384
 385         $scope->{ $name_orig }++;
 386     }
 387     $name = substr( $name, 0, $max_id_length )
 388                         if ((length( $name ) > $max_id_length) && $critical);
 389     $scope->{ $name }++;
 390     return $name;
 391 }
 392
 393 sub unreserve {
 394     my $name            = shift || '';
 395     my $schema_obj_name = shift || '';
 396     my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
 397
 398     # also trap fields that don't begin with a letter
 399     return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
 400
 401     if ( $schema_obj_name ) {
 402         ++$unreserve{"$schema_obj_name.$name"};
 403     }
 404     else {
 405         ++$unreserve{"$name (table name)"};
 406     }
 407
 408     my $unreserve = sprintf '%s_', $name;
 409     return $unreserve.$suffix;
 410 }
 411
 412 1;
 413
 414 =pod
 415
 416 =head1 SEE ALSO
 417
 418 SQL::Translator.
 419
 420 =head1 AUTHORS
 421
 422 Sam Angiuoli E<lt>angiuoli@users.sourceforge.netE<gt>,
 423 Paul Harrington E<lt>harringp@deshaw.comE<gt>,
 424 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>.
 425
 426 =cut