lib/SQL/Translator/Parser/MySQL.pm

   1 package SQL::Translator::Parser::MySQL;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: MySQL.pm,v 1.53 2006-03-16 19:24:02 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.53 $ =~ /(\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     }
 290
 291 comment : /\/\*/ /[^\*]+/ /\*\// ';'
 292     {
 293         my $comment = $item[2];
 294         $comment    =~ s/^\s*|\s*$//g;
 295         $return = $comment;
 296     }
 297
 298 field_comment : /^\s*(?:#|-{2}).*\n/
 299     {
 300         my $comment =  $item[1];
 301         $comment    =~ s/^\s*(#|--)\s*//;
 302         $comment    =~ s/\s*$//;
 303         $return     = $comment;
 304     }
 305
 306
 307 field_comment2 : /comment/i /'.*?'/
 308     {
 309         my $comment = $item[2];
 310         $comment    =~ s/^'//;
 311         $comment    =~ s/'$//;
 312         $return     = $comment;
 313     }
 314
 315 blank : /\s*/
 316
 317 field : field_comment(s?) field_name data_type field_qualifier(s?) field_comment2(?) reference_definition(?) on_update(?) field_comment(s?)
 318     {
 319         my %qualifiers  = map { %$_ } @{ $item{'field_qualifier(s?)'} || [] };
 320         if ( my @type_quals = @{ $item{'data_type'}{'qualifiers'} || [] } ) {
 321             $qualifiers{ $_ } = 1 for @type_quals;
 322         }
 323
 324         my $null = defined $qualifiers{'not_null'}
 325                    ? $qualifiers{'not_null'} : 1;
 326         delete $qualifiers{'not_null'};
 327
 328         my @comments = ( @{ $item[1] }, @{ $item[5] }, @{ $item[8] } );
 329
 330         $return = {
 331             supertype   => 'field',
 332             name        => $item{'field_name'},
 333             data_type   => $item{'data_type'}{'type'},
 334             size        => $item{'data_type'}{'size'},
 335             list        => $item{'data_type'}{'list'},
 336             null        => $null,
 337             constraints => $item{'reference_definition(?)'},
 338             comments    => [ @comments ],
 339             %qualifiers,
 340         }
 341     }
 342     | <error>
 343
 344 field_qualifier : not_null
 345     {
 346         $return = {
 347              null => $item{'not_null'},
 348         }
 349     }
 350
 351 field_qualifier : default_val
 352     {
 353         $return = {
 354              default => $item{'default_val'},
 355         }
 356     }
 357
 358 field_qualifier : auto_inc
 359     {
 360         $return = {
 361              is_auto_inc => $item{'auto_inc'},
 362         }
 363     }
 364
 365 field_qualifier : primary_key
 366     {
 367         $return = {
 368              is_primary_key => $item{'primary_key'},
 369         }
 370     }
 371
 372 field_qualifier : unsigned
 373     {
 374         $return = {
 375              is_unsigned => $item{'unsigned'},
 376         }
 377     }
 378
 379 field_qualifier : /character set/i WORD
 380     {
 381         $return = {
 382             'CHARACTER SET' => $item[2],
 383         }
 384     }
 385
 386 field_qualifier : /collate/i WORD
 387     {
 388         $return = {
 389             COLLATE => $item[2],
 390         }
 391     }
 392
 393 field_qualifier : /on update/i CURRENT_TIMESTAMP
 394     {
 395         $return = {
 396             'ON UPDATE' => $item[2],
 397         }
 398     }
 399
 400 field_qualifier : /unique/i KEY(?)
 401     {
 402         $return = {
 403             is_unique => 1,
 404         }
 405     }
 406
 407 field_qualifier : KEY
 408     {
 409         $return = {
 410             has_index => 1,
 411         }
 412     }
 413
 414 reference_definition : /references/i table_name parens_field_list(?) match_type(?) on_delete(?) on_update(?)
 415     {
 416         $return = {
 417             type             => 'foreign_key',
 418             reference_table  => $item[2],
 419             reference_fields => $item[3][0],
 420             match_type       => $item[4][0],
 421             on_delete        => $item[5][0],
 422             on_update        => $item[6][0],
 423         }
 424     }
 425
 426 match_type : /match full/i { 'full' }
 427     |
 428     /match partial/i { 'partial' }
 429
 430 on_delete : /on delete/i reference_option
 431     { $item[2] }
 432
 433 on_update :
 434     /on update/i 'CURRENT_TIMESTAMP'
 435     { $item[2] }
 436     |
 437     /on update/i reference_option
 438     { $item[2] }
 439
 440 reference_option: /restrict/i |
 441     /cascade/i   |
 442     /set null/i  |
 443     /no action/i |
 444     /set default/i
 445     { $item[1] }
 446
 447 index : normal_index
 448     | fulltext_index
 449     | <error>
 450
 451 table_name   : NAME
 452
 453 field_name   : NAME
 454
 455 index_name   : NAME
 456
 457 data_type    : WORD parens_value_list(s?) type_qualifier(s?)
 458     {
 459         my $type = $item[1];
 460         my $size; # field size, applicable only to non-set fields
 461         my $list; # set list, applicable only to sets (duh)
 462
 463         if ( uc($type) =~ /^(SET|ENUM)$/ ) {
 464             $size = undef;
 465             $list = $item[2][0];
 466         }
 467         else {
 468             $size = $item[2][0];
 469             $list = [];
 470         }
 471
 472         unless ( @{ $size || [] } ) {
 473             if ( lc $type eq 'tinyint' ) {
 474                 $size = 4;
 475             }
 476             elsif ( lc $type eq 'smallint' ) {
 477                 $size = 6;
 478             }
 479             elsif ( lc $type eq 'mediumint' ) {
 480                 $size = 9;
 481             }
 482             elsif ( $type =~ /^int(eger)?$/i ) {
 483                 $type = 'int';
 484                 $size = 11;
 485             }
 486             elsif ( lc $type eq 'bigint' ) {
 487                 $size = 20;
 488             }
 489             elsif (
 490                 lc $type =~ /(float|double|decimal|numeric|real|fixed|dec)/
 491             ) {
 492                 $size = [8,2];
 493             }
 494         }
 495
 496         if ( $type =~ /^tiny(text|blob)$/i ) {
 497             $size = 255;
 498         }
 499         elsif ( $type =~ /^(blob|text)$/i ) {
 500             $size = 65_535;
 501         }
 502         elsif ( $type =~ /^medium(blob|text)$/i ) {
 503             $size = 16_777_215;
 504         }
 505         elsif ( $type =~ /^long(blob|text)$/i ) {
 506             $size = 4_294_967_295;
 507         }
 508
 509         $return        = {
 510             type       => $type,
 511             size       => $size,
 512             list       => $list,
 513             qualifiers => $item[3],
 514         }
 515     }
 516
 517 parens_field_list : '(' field_name(s /,/) ')'
 518     { $item[2] }
 519
 520 parens_value_list : '(' VALUE(s /,/) ')'
 521     { $item[2] }
 522
 523 type_qualifier : /(BINARY|UNSIGNED|ZEROFILL)/i
 524     { lc $item[1] }
 525
 526 field_type   : WORD
 527
 528 create_index : /create/i /index/i
 529
 530 not_null     : /not/i /null/i
 531     { $return = 0 }
 532     |
 533     /null/i
 534     { $return = 1 }
 535
 536 unsigned     : /unsigned/i { $return = 0 }
 537
 538 #default_val  : /default/i /(?:')?[\s\w\d:.-]*(?:')?/
 539 #    {
 540 #        $item[2] =~ s/'//g;
 541 #        $return  =  $item[2];
 542 #    }
 543
 544 default_val :
 545     /default/i 'CURRENT_TIMESTAMP'
 546     {
 547         $return =  $item[2];
 548     }
 549     |
 550     /default/i /'(?:.*?\\')*.*?'|(?:')?[\w\d:.-]*(?:')?/
 551     {
 552         $item[2] =~ s/^\s*'|'\s*$//g;
 553         $return  =  $item[2];
 554     }
 555
 556 auto_inc : /auto_increment/i { 1 }
 557
 558 primary_key : /primary/i /key/i { 1 }
 559
 560 constraint : primary_key_def
 561     | unique_key_def
 562     | foreign_key_def
 563     | <error>
 564
 565 foreign_key_def : foreign_key_def_begin parens_field_list reference_definition
 566     {
 567         $return              =  {
 568             supertype        => 'constraint',
 569             type             => 'foreign_key',
 570             name             => $item[1],
 571             fields           => $item[2],
 572             %{ $item{'reference_definition'} },
 573         }
 574     }
 575
 576 foreign_key_def_begin : /constraint/i /foreign key/i WORD
 577     { $return = $item[3] }
 578     |
 579     /constraint/i NAME /foreign key/i
 580     { $return = $item[2] }
 581     |
 582     /constraint/i /foreign key/i
 583     { $return = '' }
 584     |
 585     /foreign key/i WORD
 586     { $return = $item[2] }
 587     |
 588     /foreign key/i
 589     { $return = '' }
 590
 591 primary_key_def : primary_key index_name(?) '(' name_with_opt_paren(s /,/) ')'
 592     {
 593         $return       = {
 594             supertype => 'constraint',
 595             name      => $item{'index_name(?)'}[0],
 596             type      => 'primary_key',
 597             fields    => $item[4],
 598         };
 599     }
 600
 601 unique_key_def : UNIQUE KEY(?) index_name(?) '(' name_with_opt_paren(s /,/) ')'
 602     {
 603         $return       = {
 604             supertype => 'constraint',
 605             name      => $item{'index_name(?)'}[0],
 606             type      => 'unique',
 607             fields    => $item[5],
 608         }
 609     }
 610
 611 normal_index : KEY index_name(?) '(' name_with_opt_paren(s /,/) ')'
 612     {
 613         $return       = {
 614             supertype => 'index',
 615             type      => 'normal',
 616             name      => $item{'index_name(?)'}[0],
 617             fields    => $item[4],
 618         }
 619     }
 620
 621 fulltext_index : /fulltext/i KEY(?) index_name(?) '(' name_with_opt_paren(s /,/) ')'
 622     {
 623         $return       = {
 624             supertype => 'index',
 625             type      => 'fulltext',
 626             name      => $item{'index_name(?)'}[0],
 627             fields    => $item[5],
 628         }
 629     }
 630
 631 name_with_opt_paren : NAME parens_value_list(s?)
 632     { $item[2][0] ? "$item[1]($item[2][0][0])" : $item[1] }
 633
 634 UNIQUE : /unique/i { 1 }
 635
 636 KEY : /key/i | /index/i
 637
 638 table_option : /comment/i /=/ /'.*?'/
 639     {
 640         my $comment = $item[3];
 641         $comment    =~ s/^'//;
 642         $comment    =~ s/'$//;
 643         $return     = { comment => $comment };
 644     }
 645     | /(default )?(charset|character set)/i /\s*=\s*/ WORD
 646     {
 647         $return = { 'CHARACTER SET' => $item[3] };
 648     }
 649     | WORD /\s*=\s*/ WORD
 650     {
 651         $return = { $item[1] => $item[3] };
 652     }
 653
 654 default : /default/i
 655
 656 ADD : /add/i
 657
 658 ALTER : /alter/i
 659
 660 CREATE : /create/i
 661
 662 TEMPORARY : /temporary/i
 663
 664 TABLE : /table/i
 665
 666 WORD : /\w+/
 667
 668 DIGITS : /\d+/
 669
 670 COMMA : ','
 671
 672 NAME    : "`" /\w+/ "`"
 673     { $item[2] }
 674     | /\w+/
 675     { $item[1] }
 676
 677 VALUE   : /[-+]?\.?\d+(?:[eE]\d+)?/
 678     { $item[1] }
 679     | /'.*?'/
 680     {
 681         # remove leading/trailing quotes
 682         my $val = $item[1];
 683         $val    =~ s/^['"]|['"]$//g;
 684         $return = $val;
 685     }
 686     | /NULL/
 687     { 'NULL' }
 688
 689 CURRENT_TIMESTAMP : /current_timestamp(\(\))?/i
 690         | /now\(\)/i
 691         { 'CURRENT_TIMESTAMP' }
 692
 693 !;
 694
 695 # -------------------------------------------------------------------
 696 sub parse {
 697     my ( $translator, $data ) = @_;
 698     my $parser = Parse::RecDescent->new($GRAMMAR);
 699
 700     local $::RD_TRACE  = $translator->trace ? 1 : undef;
 701     local $DEBUG       = $translator->debug;
 702
 703     unless (defined $parser) {
 704         return $translator->error("Error instantiating Parse::RecDescent ".
 705             "instance: Bad grammer");
 706     }
 707
 708     my $result = $parser->startrule($data);
 709     return $translator->error( "Parse failed." ) unless defined $result;
 710     warn "Parse result:".Dumper( $result ) if $DEBUG;
 711
 712     my $schema = $translator->schema;
 713     $schema->name($result->{'database_name'}) if $result->{'database_name'};
 714
 715     my @tables = sort {
 716         $result->{'tables'}{ $a }{'order'}
 717         <=>
 718         $result->{'tables'}{ $b }{'order'}
 719     } keys %{ $result->{'tables'} };
 720
 721     for my $table_name ( @tables ) {
 722         my $tdata =  $result->{tables}{ $table_name };
 723         my $table =  $schema->add_table(
 724             name  => $tdata->{'table_name'},
 725         ) or die $schema->error;
 726
 727         $table->comments( $tdata->{'comments'} );
 728
 729         my @fields = sort {
 730             $tdata->{'fields'}->{$a}->{'order'}
 731             <=>
 732             $tdata->{'fields'}->{$b}->{'order'}
 733         } keys %{ $tdata->{'fields'} };
 734
 735         for my $fname ( @fields ) {
 736             my $fdata = $tdata->{'fields'}{ $fname };
 737             my $field = $table->add_field(
 738                 name              => $fdata->{'name'},
 739                 data_type         => $fdata->{'data_type'},
 740                 size              => $fdata->{'size'},
 741                 default_value     => $fdata->{'default'},
 742                 is_auto_increment => $fdata->{'is_auto_inc'},
 743                 is_nullable       => $fdata->{'null'},
 744                 comments          => $fdata->{'comments'},
 745             ) or die $table->error;
 746
 747             $table->primary_key( $field->name ) if $fdata->{'is_primary_key'};
 748
 749             for my $qual ( qw[ binary unsigned zerofill list collate ],
 750                         'character set', 'on update' ) {
 751                 if ( my $val = $fdata->{ $qual } || $fdata->{ uc $qual } ) {
 752                     next if ref $val eq 'ARRAY' && !@$val;
 753                     $field->extra( $qual, $val );
 754                 }
 755             }
 756
 757             if ( $fdata->{'has_index'} ) {
 758                 $table->add_index(
 759                     name   => '',
 760                     type   => 'NORMAL',
 761                     fields => $fdata->{'name'},
 762                 ) or die $table->error;
 763             }
 764
 765             if ( $fdata->{'is_unique'} ) {
 766                 $table->add_constraint(
 767                     name   => '',
 768                     type   => 'UNIQUE',
 769                     fields => $fdata->{'name'},
 770                 ) or die $table->error;
 771             }
 772
 773             if ( $field->data_type =~ /(set|enum)/i && !$field->size ) {
 774                 my %extra = $field->extra;
 775                 my $longest = 0;
 776                 for my $len ( map { length } @{ $extra{'list'} || [] } ) {
 777                     $longest = $len if $len > $longest;
 778                 }
 779                 $field->size( $longest ) if $longest;
 780             }
 781
 782             for my $cdata ( @{ $fdata->{'constraints'} } ) {
 783                 next unless $cdata->{'type'} eq 'foreign_key';
 784                 $cdata->{'fields'} ||= [ $field->name ];
 785                 push @{ $tdata->{'constraints'} }, $cdata;
 786             }
 787         }
 788
 789         for my $idata ( @{ $tdata->{'indices'} || [] } ) {
 790             my $index  =  $table->add_index(
 791                 name   => $idata->{'name'},
 792                 type   => uc $idata->{'type'},
 793                 fields => $idata->{'fields'},
 794             ) or die $table->error;
 795         }
 796
 797         if ( my @options = @{ $tdata->{'table_options'} || [] } ) {
 798             $table->options( \@options ) or die $table->error;
 799         }
 800
 801         for my $cdata ( @{ $tdata->{'constraints'} || [] } ) {
 802             my $constraint       =  $table->add_constraint(
 803                 name             => $cdata->{'name'},
 804                 type             => $cdata->{'type'},
 805                 fields           => $cdata->{'fields'},
 806                 reference_table  => $cdata->{'reference_table'},
 807                 reference_fields => $cdata->{'reference_fields'},
 808                 match_type       => $cdata->{'match_type'} || '',
 809                 on_delete        => $cdata->{'on_delete'} || $cdata->{'on_delete_do'},
 810                 on_update        => $cdata->{'on_update'} || $cdata->{'on_update_do'},
 811             ) or die $table->error;
 812         }
 813     }
 814
 815     return 1;
 816 }
 817
 818 1;
 819
 820 # -------------------------------------------------------------------
 821 # Where man is not nature is barren.
 822 # William Blake
 823 # -------------------------------------------------------------------
 824
 825 =pod
 826
 827 =head1 AUTHOR
 828
 829 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>,
 830 Chris Mungall E<lt>cjm@fruitfly.orgE<gt>.
 831
 832 =head1 SEE ALSO
 833
 834 Parse::RecDescent, SQL::Translator::Schema.
 835
 836 =cut