lib/SQL/Translator/Parser/MySQL.pm

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