lib/SQL/Translator/Parser/MySQL.pm

   1 package SQL::Translator::Parser::MySQL;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: MySQL.pm,v 1.48 2005-06-15 17:58:42 kycl4rk Exp $
   5 # -------------------------------------------------------------------
   6 # Copyright (C) 2002-4 SQLFairy Authors
   7 #
   8 # This program is free software; you can redistribute it and/or
   9 # modify it under the terms of the GNU General Public License as
  10 # published by the Free Software Foundation; version 2.
  11 #
  12 # This program is distributed in the hope that it will be useful, but
  13 # WITHOUT ANY WARRANTY; without even the implied warranty of
  14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15 # General Public License for more details.
  16 #
  17 # You should have received a copy of the GNU General Public License
  18 # along with this program; if not, write to the Free Software
  19 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
  20 # 02111-1307  USA
  21 # -------------------------------------------------------------------
  22
  23 =head1 NAME
  24
  25 SQL::Translator::Parser::MySQL - parser for MySQL
  26
  27 =head1 SYNOPSIS
  28
  29   use SQL::Translator;
  30   use SQL::Translator::Parser::MySQL;
  31
  32   my $translator = SQL::Translator->new;
  33   $translator->parser("SQL::Translator::Parser::MySQL");
  34
  35 =head1 DESCRIPTION
  36
  37 The grammar is influenced heavily by Tim Bunce's "mysql2ora" grammar.
  38
  39 Here's the word from the MySQL site
  40 (http://www.mysql.com/doc/en/CREATE_TABLE.html):
  41
  42   CREATE [TEMPORARY] TABLE [IF NOT EXISTS] tbl_name [(create_definition,...)]
  43   [table_options] [select_statement]
  44
  45   or
  46
  47   CREATE [TEMPORARY] TABLE [IF NOT EXISTS] tbl_name LIKE old_table_name;
  48
  49   create_definition:
  50     col_name type [NOT NULL | NULL] [DEFAULT default_value] [AUTO_INCREMENT]
  51               [PRIMARY KEY] [reference_definition]
  52     or    PRIMARY KEY (index_col_name,...)
  53     or    KEY [index_name] (index_col_name,...)
  54     or    INDEX [index_name] (index_col_name,...)
  55     or    UNIQUE [INDEX] [index_name] (index_col_name,...)
  56     or    FULLTEXT [INDEX] [index_name] (index_col_name,...)
  57     or    [CONSTRAINT symbol] FOREIGN KEY [index_name] (index_col_name,...)
  58               [reference_definition]
  59     or    CHECK (expr)
  60
  61   type:
  62           TINYINT[(length)] [UNSIGNED] [ZEROFILL]
  63     or    SMALLINT[(length)] [UNSIGNED] [ZEROFILL]
  64     or    MEDIUMINT[(length)] [UNSIGNED] [ZEROFILL]
  65     or    INT[(length)] [UNSIGNED] [ZEROFILL]
  66     or    INTEGER[(length)] [UNSIGNED] [ZEROFILL]
  67     or    BIGINT[(length)] [UNSIGNED] [ZEROFILL]
  68     or    REAL[(length,decimals)] [UNSIGNED] [ZEROFILL]
  69     or    DOUBLE[(length,decimals)] [UNSIGNED] [ZEROFILL]
  70     or    FLOAT[(length,decimals)] [UNSIGNED] [ZEROFILL]
  71     or    DECIMAL(length,decimals) [UNSIGNED] [ZEROFILL]
  72     or    NUMERIC(length,decimals) [UNSIGNED] [ZEROFILL]
  73     or    CHAR(length) [BINARY]
  74     or    VARCHAR(length) [BINARY]
  75     or    DATE
  76     or    TIME
  77     or    TIMESTAMP
  78     or    DATETIME
  79     or    TINYBLOB
  80     or    BLOB
  81     or    MEDIUMBLOB
  82     or    LONGBLOB
  83     or    TINYTEXT
  84     or    TEXT
  85     or    MEDIUMTEXT
  86     or    LONGTEXT
  87     or    ENUM(value1,value2,value3,...)
  88     or    SET(value1,value2,value3,...)
  89
  90   index_col_name:
  91           col_name [(length)]
  92
  93   reference_definition:
  94           REFERENCES tbl_name [(index_col_name,...)]
  95                      [MATCH FULL | MATCH PARTIAL]
  96                      [ON DELETE reference_option]
  97                      [ON UPDATE reference_option]
  98
  99   reference_option:
 100           RESTRICT | CASCADE | SET NULL | NO ACTION | SET DEFAULT
 101
 102   table_options:
 103           TYPE = {BDB | HEAP | ISAM | InnoDB | MERGE | MRG_MYISAM | MYISAM }
 104   or      AUTO_INCREMENT = #
 105   or      AVG_ROW_LENGTH = #
 106   or      CHECKSUM = {0 | 1}
 107   or      COMMENT = "string"
 108   or      MAX_ROWS = #
 109   or      MIN_ROWS = #
 110   or      PACK_KEYS = {0 | 1 | DEFAULT}
 111   or      PASSWORD = "string"
 112   or      DELAY_KEY_WRITE = {0 | 1}
 113   or      ROW_FORMAT= { default | dynamic | fixed | compressed }
 114   or      RAID_TYPE= {1 | STRIPED | RAID0 } RAID_CHUNKS=#  RAID_CHUNKSIZE=#
 115   or      UNION = (table_name,[table_name...])
 116   or      INSERT_METHOD= {NO | FIRST | LAST }
 117   or      DATA DIRECTORY="absolute path to directory"
 118   or      INDEX DIRECTORY="absolute path to directory"
 119
 120 A subset of the ALTER TABLE syntax that allows addition of foreign keys:
 121
 122   ALTER [IGNORE] TABLE tbl_name alter_specification [, alter_specification] ...
 123
 124   alter_specification:
 125           ADD [CONSTRAINT [symbol]]
 126           FOREIGN KEY [index_name] (index_col_name,...)
 127              [reference_definition]
 128
 129 A subset of INSERT that we ignore:
 130
 131   INSERT anything
 132
 133 =cut
 134
 135 use strict;
 136 use vars qw[ $DEBUG $VERSION $GRAMMAR @EXPORT_OK ];
 137 $VERSION = sprintf "%d.%02d", q$Revision: 1.48 $ =~ /(\d+)\.(\d+)/;
 138 $DEBUG   = 0 unless defined $DEBUG;
 139
 140 use Data::Dumper;
 141 use Parse::RecDescent;
 142 use Exporter;
 143 use base qw(Exporter);
 144
 145 @EXPORT_OK = qw(parse);
 146
 147 # Enable warnings within the Parse::RecDescent module.
 148 $::RD_ERRORS = 1; # Make sure the parser dies when it encounters an error
 149 $::RD_WARN   = 1; # Enable warnings. This will warn on unused rules &c.
 150 $::RD_HINT   = 1; # Give out hints to help fix problems.
 151
 152 $GRAMMAR = q!
 153
 154 {
 155     my ( $database_name, %tables, $table_order, @table_comments );
 156 }
 157
 158 #
 159 # The "eofile" rule makes the parser fail if any "statement" rule
 160 # fails.  Otherwise, the first successful match by a "statement"
 161 # won't cause the failure needed to know that the parse, as a whole,
 162 # failed. -ky
 163 #
 164 startrule : statement(s) eofile {
 165     { tables => \%tables, database_name => $database_name }
 166 }
 167
 168 eofile : /^\Z/
 169
 170 statement : comment
 171     | use
 172     | set
 173     | drop
 174     | create
 175     | alter
 176     | insert
 177     | <error>
 178
 179 use : /use/i WORD ';'
 180     {
 181         $database_name = $item[2];
 182         @table_comments = ();
 183     }
 184
 185 set : /set/i /[^;]+/ ';'
 186     { @table_comments = () }
 187
 188 drop : /drop/i TABLE /[^;]+/ ';'
 189
 190 drop : /drop/i WORD(s) ';'
 191     { @table_comments = () }
 192
 193 insert : /insert/i  /[^;]+/ ';'
 194
 195 alter : ALTER TABLE table_name alter_specification(s /,/) ';'
 196     {
 197         my $table_name                       = $item{'table_name'};
 198     die "Cannot ALTER table '$table_name'; it does not exist"
 199         unless $tables{ $table_name };
 200         for my $definition ( @{ $item[4] } ) {
 201         $definition->{'extra'}->{'alter'} = 1;
 202         push @{ $tables{ $table_name }{'constraints'} }, $definition;
 203     }
 204     }
 205
 206 alter_specification : ADD foreign_key_def
 207     { $return = $item[2] }
 208
 209 create : CREATE /database/i WORD ';'
 210     { @table_comments = () }
 211
 212 create : CREATE TEMPORARY(?) TABLE opt_if_not_exists(?) table_name '(' create_definition(s /,/) /(,\s*)?\)/ table_option(s?) ';'
 213     {
 214         my $table_name                       = $item{'table_name'};
 215         $tables{ $table_name }{'order'}      = ++$table_order;
 216         $tables{ $table_name }{'table_name'} = $table_name;
 217
 218         if ( @table_comments ) {
 219             $tables{ $table_name }{'comments'} = [ @table_comments ];
 220             @table_comments = ();
 221         }
 222
 223         my $i = 1;
 224         for my $definition ( @{ $item[7] } ) {
 225             if ( $definition->{'supertype'} eq 'field' ) {
 226                 my $field_name = $definition->{'name'};
 227                 $tables{ $table_name }{'fields'}{ $field_name } =
 228                     { %$definition, order => $i };
 229                 $i++;
 230
 231                 if ( $definition->{'is_primary_key'} ) {
 232                     push @{ $tables{ $table_name }{'constraints'} },
 233                         {
 234                             type   => 'primary_key',
 235                             fields => [ $field_name ],
 236                         }
 237                     ;
 238                 }
 239             }
 240             elsif ( $definition->{'supertype'} eq 'constraint' ) {
 241                 push @{ $tables{ $table_name }{'constraints'} }, $definition;
 242             }
 243             elsif ( $definition->{'supertype'} eq 'index' ) {
 244                 push @{ $tables{ $table_name }{'indices'} }, $definition;
 245             }
 246         }
 247
 248         if ( my @options = @{ $item{'table_option(s?)'} } ) {
 249             for my $option ( @options ) {
 250                 my ( $key, $value ) = each %$option;
 251                 if ( $key eq 'comment' ) {
 252                     push @{ $tables{ $table_name }{'comments'} }, $value;
 253                 }
 254                 else {
 255                     push @{ $tables{ $table_name }{'table_options'} }, $option;
 256                 }
 257             }
 258         }
 259
 260         1;
 261     }
 262
 263 opt_if_not_exists : /if not exists/i
 264
 265 create : CREATE UNIQUE(?) /(index|key)/i index_name /on/i table_name '(' field_name(s /,/) ')' ';'
 266     {
 267         @table_comments = ();
 268         push @{ $tables{ $item{'table_name'} }{'indices'} },
 269             {
 270                 name   => $item[4],
 271                 type   => $item[2] ? 'unique' : 'normal',
 272                 fields => $item[8],
 273             }
 274         ;
 275     }
 276
 277 create_definition : constraint
 278     | index
 279     | field
 280     | comment
 281     | <error>
 282
 283 comment : /^\s*(?:#|-{2}).*\n/
 284     {
 285         my $comment =  $item[1];
 286         $comment    =~ s/^\s*(#|--)\s*//;
 287         $comment    =~ s/\s*$//;
 288         $return     = $comment;
 289         push @table_comments, $comment;
 290     }
 291
 292 comment : /\/\*/ /[^\*]+/ /\*\// ';'
 293     {
 294         my $comment = $item[2];
 295         $comment    =~ s/^\s*|\s*$//g;
 296         $return = $comment;
 297     }
 298
 299 field_comment : /^\s*(?:#|-{2}).*\n/
 300     {
 301         my $comment =  $item[1];
 302         $comment    =~ s/^\s*(#|--)\s*//;
 303         $comment    =~ s/\s*$//;
 304         $return     = $comment;
 305     }
 306
 307
 308 field_comment2 : /comment/i /'.*?'/
 309     {
 310         my $comment = $item[2];
 311         $comment    =~ s/^'//;
 312         $comment    =~ s/'$//;
 313         $return     = $comment;
 314     }
 315
 316 blank : /\s*/
 317
 318 field : field_comment(s?) field_name data_type field_qualifier(s?) field_comment2(?) reference_definition(?) on_update_do(?) field_comment(s?)
 319     {
 320         my %qualifiers  = map { %$_ } @{ $item{'field_qualifier(s?)'} || [] };
 321         if ( my @type_quals = @{ $item{'data_type'}{'qualifiers'} || [] } ) {
 322             $qualifiers{ $_ } = 1 for @type_quals;
 323         }
 324
 325         my $null = defined $qualifiers{'not_null'}
 326                    ? $qualifiers{'not_null'} : 1;
 327         delete $qualifiers{'not_null'};
 328
 329         my @comments = ( @{ $item[1] }, @{ $item[5] }, @{ $item[8] } );
 330
 331         $return = {
 332             supertype   => 'field',
 333             name        => $item{'field_name'},
 334             data_type   => $item{'data_type'}{'type'},
 335             size        => $item{'data_type'}{'size'},
 336             list        => $item{'data_type'}{'list'},
 337             null        => $null,
 338             constraints => $item{'reference_definition(?)'},
 339             comments    => [ @comments ],
 340             %qualifiers,
 341         }
 342     }
 343     | <error>
 344
 345 field_qualifier : not_null
 346     {
 347         $return = {
 348              null => $item{'not_null'},
 349         }
 350     }
 351
 352 field_qualifier : default_val
 353     {
 354         $return = {
 355              default => $item{'default_val'},
 356         }
 357     }
 358
 359 field_qualifier : auto_inc
 360     {
 361         $return = {
 362              is_auto_inc => $item{'auto_inc'},
 363         }
 364     }
 365
 366 field_qualifier : primary_key
 367     {
 368         $return = {
 369              is_primary_key => $item{'primary_key'},
 370         }
 371     }
 372
 373 field_qualifier : unsigned
 374     {
 375         $return = {
 376              is_unsigned => $item{'unsigned'},
 377         }
 378     }
 379
 380 field_qualifier : /character set/i WORD
 381     {
 382         $return = {
 383             character_set => $item[2],
 384         }
 385     }
 386
 387 reference_definition : /references/i table_name parens_field_list(?) match_type(?) on_delete_do(?) on_update_do(?)
 388     {
 389         $return = {
 390             type             => 'foreign_key',
 391             reference_table  => $item[2],
 392             reference_fields => $item[3][0],
 393             match_type       => $item[4][0],
 394             on_delete_do     => $item[5][0],
 395             on_update_do     => $item[6][0],
 396         }
 397     }
 398
 399 match_type : /match full/i { 'full' }
 400     |
 401     /match partial/i { 'partial' }
 402
 403 on_delete_do : /on delete/i reference_option
 404     { $item[2] }
 405
 406 on_update_do :
 407     /on update/i 'CURRENT_TIMESTAMP'
 408     { $item[2] }
 409     |
 410     /on update/i reference_option
 411     { $item[2] }
 412
 413 reference_option: /restrict/i |
 414     /cascade/i   |
 415     /set null/i  |
 416     /no action/i |
 417     /set default/i
 418     { $item[1] }
 419
 420 index : normal_index
 421     | fulltext_index
 422     | <error>
 423
 424 table_name   : NAME
 425
 426 field_name   : NAME
 427
 428 index_name   : NAME
 429
 430 data_type    : WORD parens_value_list(s?) type_qualifier(s?)
 431     {
 432         my $type = $item[1];
 433         my $size; # field size, applicable only to non-set fields
 434         my $list; # set list, applicable only to sets (duh)
 435
 436         if ( uc($type) =~ /^(SET|ENUM)$/ ) {
 437             $size = undef;
 438             $list = $item[2][0];
 439         }
 440         else {
 441             $size = $item[2][0];
 442             $list = [];
 443         }
 444
 445         unless ( @{ $size || [] } ) {
 446             if ( lc $type eq 'tinyint' ) {
 447                 $size = 4;
 448             }
 449             elsif ( lc $type eq 'smallint' ) {
 450                 $size = 6;
 451             }
 452             elsif ( lc $type eq 'mediumint' ) {
 453                 $size = 9;
 454             }
 455             elsif ( $type =~ /^int(eger)?$/i ) {
 456                 $type = 'int';
 457                 $size = 11;
 458             }
 459             elsif ( lc $type eq 'bigint' ) {
 460                 $size = 20;
 461             }
 462             elsif (
 463                 lc $type =~ /(float|double|decimal|numeric|real|fixed|dec)/
 464             ) {
 465                 $size = [8,2];
 466             }
 467         }
 468
 469         if ( $type =~ /^tiny(text|blob)$/i ) {
 470             $size = 255;
 471         }
 472         elsif ( $type =~ /^(blob|text)$/i ) {
 473             $size = 65_535;
 474         }
 475         elsif ( $type =~ /^medium(blob|text)$/i ) {
 476             $size = 16_777_215;
 477         }
 478         elsif ( $type =~ /^long(blob|text)$/i ) {
 479             $size = 4_294_967_295;
 480         }
 481
 482         $return        = {
 483             type       => $type,
 484             size       => $size,
 485             list       => $list,
 486             qualifiers => $item[3],
 487         }
 488     }
 489
 490 parens_field_list : '(' field_name(s /,/) ')'
 491     { $item[2] }
 492
 493 parens_value_list : '(' VALUE(s /,/) ')'
 494     { $item[2] }
 495
 496 type_qualifier : /(BINARY|UNSIGNED|ZEROFILL)/i
 497     { lc $item[1] }
 498
 499 field_type   : WORD
 500
 501 create_index : /create/i /index/i
 502
 503 not_null     : /not/i /null/i
 504     { $return = 0 }
 505     |
 506     /null/i
 507     { $return = 1 }
 508
 509 unsigned     : /unsigned/i { $return = 0 }
 510
 511 #default_val  : /default/i /(?:')?[\s\w\d:.-]*(?:')?/
 512 #    {
 513 #        $item[2] =~ s/'//g;
 514 #        $return  =  $item[2];
 515 #    }
 516
 517 default_val :
 518     /default/i 'CURRENT_TIMESTAMP'
 519     {
 520         $return =  $item[2];
 521     }
 522     |
 523     /default/i /'(?:.*?\\')*.*?'|(?:')?[\w\d:.-]*(?:')?/
 524     {
 525         $item[2] =~ s/^\s*'|'\s*$//g;
 526         $return  =  $item[2];
 527     }
 528
 529 auto_inc : /auto_increment/i { 1 }
 530
 531 primary_key : /primary/i /key/i { 1 }
 532
 533 constraint : primary_key_def
 534     | unique_key_def
 535     | foreign_key_def
 536     | <error>
 537
 538 foreign_key_def : foreign_key_def_begin parens_field_list reference_definition
 539     {
 540         $return              =  {
 541             supertype        => 'constraint',
 542             type             => 'foreign_key',
 543             name             => $item[1],
 544             fields           => $item[2],
 545             %{ $item{'reference_definition'} },
 546         }
 547     }
 548
 549 foreign_key_def_begin : /constraint/i /foreign key/i WORD
 550     { $return = $item[3] }
 551     |
 552     /constraint/i NAME /foreign key/i
 553     { $return = $item[2] }
 554     |
 555     /constraint/i /foreign key/i
 556     { $return = '' }
 557     |
 558     /foreign key/i WORD
 559     { $return = $item[2] }
 560     |
 561     /foreign key/i
 562     { $return = '' }
 563
 564 primary_key_def : primary_key index_name(?) '(' name_with_opt_paren(s /,/) ')'
 565     {
 566         $return       = {
 567             supertype => 'constraint',
 568             name      => $item{'index_name(?)'}[0],
 569             type      => 'primary_key',
 570             fields    => $item[4],
 571         };
 572     }
 573
 574 unique_key_def : UNIQUE KEY(?) index_name(?) '(' name_with_opt_paren(s /,/) ')'
 575     {
 576         $return       = {
 577             supertype => 'constraint',
 578             name      => $item{'index_name(?)'}[0],
 579             type      => 'unique',
 580             fields    => $item[5],
 581         }
 582     }
 583
 584 normal_index : KEY index_name(?) '(' name_with_opt_paren(s /,/) ')'
 585     {
 586         $return       = {
 587             supertype => 'index',
 588             type      => 'normal',
 589             name      => $item{'index_name(?)'}[0],
 590             fields    => $item[4],
 591         }
 592     }
 593
 594 fulltext_index : /fulltext/i KEY(?) index_name(?) '(' name_with_opt_paren(s /,/) ')'
 595     {
 596         $return       = {
 597             supertype => 'index',
 598             type      => 'fulltext',
 599             name      => $item{'index_name(?)'}[0],
 600             fields    => $item[5],
 601         }
 602     }
 603
 604 name_with_opt_paren : NAME parens_value_list(s?)
 605     { $item[2][0] ? "$item[1]($item[2][0][0])" : $item[1] }
 606
 607 UNIQUE : /unique/i { 1 }
 608
 609 KEY : /key/i | /index/i
 610
 611 table_option : 'DEFAULT CHARSET' /\s*=\s*/ WORD
 612     {
 613         $return = { $item[1] => $item[3] };
 614     }
 615     | /comment/i /=/ /'.*?'/
 616     {
 617         my $comment = $item[3];
 618         $comment    =~ s/^'//;
 619         $comment    =~ s/'$//;
 620         $return     = { comment => $comment };
 621     }
 622     | WORD /\s*=\s*/ WORD
 623     {
 624         $return = { $item[1] => $item[3] };
 625     }
 626
 627 ADD : /add/i
 628
 629 ALTER : /alter/i
 630
 631 CREATE : /create/i
 632
 633 TEMPORARY : /temporary/i
 634
 635 TABLE : /table/i
 636
 637 WORD : /\w+/
 638
 639 DIGITS : /\d+/
 640
 641 COMMA : ','
 642
 643 NAME    : "`" /\w+/ "`"
 644     { $item[2] }
 645     | /\w+/
 646     { $item[1] }
 647
 648 VALUE   : /[-+]?\.?\d+(?:[eE]\d+)?/
 649     { $item[1] }
 650     | /'.*?'/
 651     {
 652         # remove leading/trailing quotes
 653         my $val = $item[1];
 654         $val    =~ s/^['"]|['"]$//g;
 655         $return = $val;
 656     }
 657     | /NULL/
 658     { 'NULL' }
 659
 660 !;
 661
 662 # -------------------------------------------------------------------
 663 sub parse {
 664     my ( $translator, $data ) = @_;
 665     my $parser = Parse::RecDescent->new($GRAMMAR);
 666
 667     local $::RD_TRACE  = $translator->trace ? 1 : undef;
 668     local $DEBUG       = $translator->debug;
 669
 670     unless (defined $parser) {
 671         return $translator->error("Error instantiating Parse::RecDescent ".
 672             "instance: Bad grammer");
 673     }
 674
 675     my $result = $parser->startrule($data);
 676     return $translator->error( "Parse failed." ) unless defined $result;
 677     warn "Parse result:".Dumper( $result ) if $DEBUG;
 678
 679     my $schema = $translator->schema;
 680     $schema->name($result->{'database_name'}) if $result->{'database_name'};
 681
 682     my @tables = sort {
 683         $result->{'tables'}{ $a }{'order'}
 684         <=>
 685         $result->{'tables'}{ $b }{'order'}
 686     } keys %{ $result->{'tables'} };
 687
 688     for my $table_name ( @tables ) {
 689         my $tdata =  $result->{tables}{ $table_name };
 690         my $table =  $schema->add_table(
 691             name  => $tdata->{'table_name'},
 692         ) or die $schema->error;
 693
 694         $table->comments( $tdata->{'comments'} );
 695
 696         my @fields = sort {
 697             $tdata->{'fields'}->{$a}->{'order'}
 698             <=>
 699             $tdata->{'fields'}->{$b}->{'order'}
 700         } keys %{ $tdata->{'fields'} };
 701
 702         for my $fname ( @fields ) {
 703             my $fdata = $tdata->{'fields'}{ $fname };
 704             my $field = $table->add_field(
 705                 name              => $fdata->{'name'},
 706                 data_type         => $fdata->{'data_type'},
 707                 size              => $fdata->{'size'},
 708                 default_value     => $fdata->{'default'},
 709                 is_auto_increment => $fdata->{'is_auto_inc'},
 710                 is_nullable       => $fdata->{'null'},
 711                 comments          => $fdata->{'comments'},
 712             ) or die $table->error;
 713
 714             $table->primary_key( $field->name ) if $fdata->{'is_primary_key'};
 715
 716             for my $qual ( qw[ binary unsigned zerofill list ] ) {
 717                 if ( my $val = $fdata->{ $qual } || $fdata->{ uc $qual } ) {
 718                     next if ref $val eq 'ARRAY' && !@$val;
 719                     $field->extra( $qual, $val );
 720                 }
 721             }
 722
 723             if ( $field->data_type =~ /(set|enum)/i && !$field->size ) {
 724                 my %extra = $field->extra;
 725                 my $longest = 0;
 726                 for my $len ( map { length } @{ $extra{'list'} || [] } ) {
 727                     $longest = $len if $len > $longest;
 728                 }
 729                 $field->size( $longest ) if $longest;
 730             }
 731
 732             for my $cdata ( @{ $fdata->{'constraints'} } ) {
 733                 next unless $cdata->{'type'} eq 'foreign_key';
 734                 $cdata->{'fields'} ||= [ $field->name ];
 735                 push @{ $tdata->{'constraints'} }, $cdata;
 736             }
 737         }
 738
 739         for my $idata ( @{ $tdata->{'indices'} || [] } ) {
 740             my $index  =  $table->add_index(
 741                 name   => $idata->{'name'},
 742                 type   => uc $idata->{'type'},
 743                 fields => $idata->{'fields'},
 744             ) or die $table->error;
 745         }
 746
 747         if ( my @options = @{ $tdata->{'table_options'} || [] } ) {
 748             $table->options( \@options ) or die $table->error;
 749         }
 750
 751         for my $cdata ( @{ $tdata->{'constraints'} || [] } ) {
 752             my $constraint       =  $table->add_constraint(
 753                 name             => $cdata->{'name'},
 754                 type             => $cdata->{'type'},
 755                 fields           => $cdata->{'fields'},
 756                 reference_table  => $cdata->{'reference_table'},
 757                 reference_fields => $cdata->{'reference_fields'},
 758                 match_type       => $cdata->{'match_type'} || '',
 759                 on_delete        => $cdata->{'on_delete_do'},
 760                 on_update        => $cdata->{'on_update_do'},
 761             ) or die $table->error;
 762         }
 763     }
 764
 765     return 1;
 766 }
 767
 768 1;
 769
 770 # -------------------------------------------------------------------
 771 # Where man is not nature is barren.
 772 # William Blake
 773 # -------------------------------------------------------------------
 774
 775 =pod
 776
 777 =head1 AUTHOR
 778
 779 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>,
 780 Chris Mungall E<lt>cjm@fruitfly.orgE<gt>.
 781
 782 =head1 SEE ALSO
 783
 784 perl(1), Parse::RecDescent, SQL::Translator::Schema.
 785
 786 =cut