lib/SQL/Translator/Parser/MySQL.pm

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