lib/SQL/Translator/Producer/Sybase.pm

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