lib/SQL/Translator/Parser/MySQL.pm

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