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 sub produce {
 118     my $translator     = shift;
 119     $DEBUG             = $translator->debug;
 120     $WARN              = $translator->show_warnings;
 121     my $no_comments    = $translator->no_comments;
 122     my $add_drop_table = $translator->add_drop_table;
 123     my $schema         = $translator->schema;
 124
 125     my $output;
 126     $output .= header_comment unless ($no_comments);
 127
 128     for my $table ( $schema->get_tables ) {
 129         my $table_name    = $table->name or next;
 130         $table_name       = mk_name( $table_name, '', undef, 1 );
 131         my $table_name_ur = unreserve($table_name) || '';
 132
 133         my ( @comments, @field_defs, @index_defs, @constraint_defs );
 134
 135         push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;
 136
 137         push @comments, map { "-- $_" } $table->comments;
 138
 139         #
 140         # Fields
 141         #
 142         my %field_name_scope;
 143         for my $field ( $table->get_fields ) {
 144             my $field_name    = mk_name(
 145                 $field->name, '', \%field_name_scope, undef,1
 146             );
 147             my $field_name_ur = unreserve( $field_name, $table_name );
 148             my $field_def     = qq["$field_name_ur"];
 149             $field_def        =~ s/\"//g;
 150             if ( $field_def =~ /identity/ ){
 151                 $field_def =~ s/identity/pidentity/;
 152             }
 153
 154             #
 155             # Datatype
 156             #
 157             my $data_type      = lc $field->data_type;
 158             my $orig_data_type = $data_type;
 159             my %extra          = $field->extra;
 160             my $list           = $extra{'list'} || [];
 161             # \todo deal with embedded quotes
 162             my $commalist      = join( ', ', map { qq['$_'] } @$list );
 163             my $seq_name;
 164
 165             if ( $data_type eq 'enum' ) {
 166                 my $check_name = mk_name(
 167                     $table_name.'_'.$field_name, 'chk' ,undef, 1
 168                 );
 169                 push @constraint_defs,
 170                 "CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
 171                 $data_type .= 'character varying';
 172             }
 173             elsif ( $data_type eq 'set' ) {
 174                 $data_type .= 'character varying';
 175             }
 176             elsif ( $field->is_auto_increment ) {
 177                 $field_def .= ' IDENTITY';
 178             }
 179             else {
 180                 if ( defined $translate{ $data_type } ) {
 181                     $data_type = $translate{ $data_type };
 182                 }
 183                 else {
 184                     warn "Unknown datatype: $data_type ",
 185                         "($table_name.$field_name)\n" if $WARN;
 186                 }
 187             }
 188
 189             my $size = $field->size;
 190             unless ( $size ) {
 191                 if ( $data_type =~ /numeric/ ) {
 192                     $size = '9,0';
 193                 }
 194                 elsif ( $orig_data_type eq 'text' ) {
 195                     #interpret text fields as long varchars
 196                     $size = '255';
 197                 }
 198                 elsif (
 199                     $data_type eq 'varchar' &&
 200                     $orig_data_type eq 'boolean'
 201                 ) {
 202                     $size = '6';
 203                 }
 204                 elsif ( $data_type eq 'varchar' ) {
 205                     $size = '255';
 206                 }
 207             }
 208
 209             $field_def .= " $data_type";
 210             $field_def .= "($size)" if $size;
 211
 212             #
 213             # Default value
 214             #
 215             my $default = $field->default_value;
 216             if ( defined $default ) {
 217                 $field_def .= sprintf( ' DEFAULT %s',
 218                     ( $field->is_auto_increment && $seq_name )
 219                     ? qq[nextval('"$seq_name"'::text)] :
 220                     ( $default =~ m/null/i ) ? 'NULL' : "'$default'"
 221                 );
 222             }
 223
 224             #
 225             # Not null constraint
 226             #
 227             unless ( $field->is_nullable ) {
 228                 $field_def .= ' NOT NULL';
 229             }
 230             else {
 231                 $field_def .= ' NULL' if $data_type ne 'bit';
 232             }
 233
 234             push @field_defs, $field_def;
 235         }
 236
 237         #
 238         # Constraint Declarations
 239         #
 240         my @constraint_decs = ();
 241         my $c_name_default;
 242         for my $constraint ( $table->get_constraints ) {
 243             my $name    = $constraint->name || '';
 244             my $type    = $constraint->type || NORMAL;
 245             my @fields  = map { unreserve( $_, $table_name ) }
 246                 $constraint->fields;
 247             my @rfields = map { unreserve( $_, $table_name ) }
 248                 $constraint->reference_fields;
 249             next unless @fields;
 250
 251             if ( $type eq PRIMARY_KEY ) {
 252                 $name ||= mk_name( $table_name, 'pk', undef,1 );
 253                 push @constraint_defs,
 254                     "CONSTRAINT $name PRIMARY KEY ".
 255                     '(' . join( ', ', @fields ) . ')';
 256             }
 257             elsif ( $type eq FOREIGN_KEY ) {
 258                 $name ||= mk_name( $table_name, 'fk', undef,1 );
 259                 push @constraint_defs,
 260                     "CONSTRAINT $name FOREIGN KEY".
 261                     ' (' . join( ', ', @fields ) . ') REFERENCES '.
 262                     $constraint->reference_table.
 263                     ' (' . join( ', ', @rfields ) . ')';
 264             }
 265             elsif ( $type eq UNIQUE ) {
 266                 $name ||= mk_name(
 267                     $table_name,
 268                     $name || ++$c_name_default,undef, 1
 269                 );
 270                 push @constraint_defs,
 271                     "CONSTRAINT $name UNIQUE " .
 272                     '(' . join( ', ', @fields ) . ')';
 273             }
 274         }
 275
 276         #
 277         # Indices
 278         #
 279         for my $index ( $table->get_indices ) {
 280             push @index_defs,
 281                 'CREATE INDEX ' . $index->name .
 282                 " ON $table_name (".
 283                 join( ', ', $index->fields ) . ");";
 284         }
 285
 286         my $create_statement;
 287         $create_statement  = qq[DROP TABLE $table_name_ur;\n]
 288             if $add_drop_table;
 289         $create_statement .= qq[CREATE TABLE $table_name_ur (\n].
 290             join( ",\n",
 291                 map { "  $_" } @field_defs, @constraint_defs
 292             ).
 293             "\n);"
 294         ;
 295
 296         $output .= join( "\n\n",
 297             @comments,
 298             $create_statement,
 299             @index_defs,
 300             ''
 301         );
 302     }
 303
 304     foreach my $view ( $schema->get_views ) {
 305         my (@comments, $view_name);
 306
 307         $view_name = $view->name();
 308         push @comments, "--\n-- View: $view_name\n--" unless $no_comments;
 309
 310         # text of view is already a 'create view' statement so no need
 311         # to do anything fancy.
 312
 313         $output .= join("\n\n",
 314                        @comments,
 315                        $view->sql(),
 316                        );
 317     }
 318
 319
 320     foreach my $procedure ( $schema->get_procedures ) {
 321         my (@comments, $procedure_name);
 322
 323         $procedure_name = $procedure->name();
 324         push @comments,
 325             "--\n-- Procedure: $procedure_name\n--" unless $no_comments;
 326
 327         # text of procedure  already has the 'create procedure' stuff
 328         # so there is no need to do anything fancy. However, we should
 329         # think about doing fancy stuff with granting permissions and
 330         # so on.
 331
 332         $output .= join("\n\n",
 333                        @comments,
 334                        $procedure->sql(),
 335                        );
 336     }
 337
 338     if ( $WARN ) {
 339         if ( %truncated ) {
 340             warn "Truncated " . keys( %truncated ) . " names:\n";
 341             warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
 342         }
 343
 344         if ( %unreserve ) {
 345             warn "Encounted " . keys( %unreserve ) .
 346                 " unsafe names in schema (reserved or invalid):\n";
 347             warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
 348         }
 349     }
 350
 351     return $output;
 352 }
 353
 354 sub mk_name {
 355     my $basename      = shift || '';
 356     my $type          = shift || '';
 357     my $scope         = shift || '';
 358     my $critical      = shift || '';
 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
 367     if ( $basename ne $basename_orig and $critical ) {
 368         my $show_type = $type ? "+'$type'" : "";
 369         warn "Truncating '$basename_orig'$show_type to $max_id_length ",
 370             "character limit to make '$name'\n" if $WARN;
 371         $truncated{ $basename_orig } = $name;
 372     }
 373
 374     $scope ||= \%global_names;
 375     if ( my $prev = $scope->{ $name } ) {
 376         my $name_orig = $name;
 377         $name        .= sprintf( "%02d", ++$prev );
 378         substr($name, $max_id_length - 3) = "00"
 379             if length( $name ) > $max_id_length;
 380
 381         warn "The name '$name_orig' has been changed to ",
 382              "'$name' to make it unique.\n" if $WARN;
 383
 384         $scope->{ $name_orig }++;
 385     }
 386     $name = substr( $name, 0, $max_id_length )
 387                         if ((length( $name ) > $max_id_length) && $critical);
 388     $scope->{ $name }++;
 389     return $name;
 390 }
 391
 392 sub unreserve {
 393     my $name            = shift || '';
 394     my $schema_obj_name = shift || '';
 395     my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
 396
 397     # also trap fields that don't begin with a letter
 398     return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
 399
 400     if ( $schema_obj_name ) {
 401         ++$unreserve{"$schema_obj_name.$name"};
 402     }
 403     else {
 404         ++$unreserve{"$name (table name)"};
 405     }
 406
 407     my $unreserve = sprintf '%s_', $name;
 408     return $unreserve.$suffix;
 409 }
 410
 411 1;
 412
 413 =pod
 414
 415 =head1 SEE ALSO
 416
 417 SQL::Translator.
 418
 419 =head1 AUTHORS
 420
 421 Sam Angiuoli E<lt>angiuoli@users.sourceforge.netE<gt>,
 422 Paul Harrington E<lt>harringp@deshaw.comE<gt>,
 423 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>.
 424
 425 =cut