lib/SQL/Translator/Parser/MySQL.pm

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