lib/SQL/Translator/Parser/MySQL.pm

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