lib/SQL/Translator/Parser/MySQL.pm

   1 package SQL::Translator::Parser::MySQL;
   2
   3 # -------------------------------------------------------------------
   4 # Copyright (C) 2002-2009 SQLFairy Authors
   5 #
   6 # This program is free software; you can redistribute it and/or
   7 # modify it under the terms of the GNU General Public License as
   8 # published by the Free Software Foundation; version 2.
   9 #
  10 # This program is distributed in the hope that it will be useful, but
  11 # WITHOUT ANY WARRANTY; without even the implied warranty of
  12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 # General Public License for more details.
  14 #
  15 # You should have received a copy of the GNU General Public License
  16 # along with this program; if not, write to the Free Software
  17 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
  18 # 02111-1307  USA
  19 # -------------------------------------------------------------------
  20
  21 =head1 NAME
  22
  23 SQL::Translator::Parser::MySQL - parser for MySQL
  24
  25 =head1 SYNOPSIS
  26
  27   use SQL::Translator;
  28   use SQL::Translator::Parser::MySQL;
  29
  30   my $translator = SQL::Translator->new;
  31   $translator->parser("SQL::Translator::Parser::MySQL");
  32
  33 =head1 DESCRIPTION
  34
  35 The grammar is influenced heavily by Tim Bunce's "mysql2ora" grammar.
  36
  37 Here's the word from the MySQL site
  38 (http://www.mysql.com/doc/en/CREATE_TABLE.html):
  39
  40   CREATE [TEMPORARY] TABLE [IF NOT EXISTS] tbl_name [(create_definition,...)]
  41   [table_options] [select_statement]
  42
  43   or
  44
  45   CREATE [TEMPORARY] TABLE [IF NOT EXISTS] tbl_name LIKE old_table_name;
  46
  47   create_definition:
  48     col_name type [NOT NULL | NULL] [DEFAULT default_value] [AUTO_INCREMENT]
  49               [PRIMARY KEY] [reference_definition]
  50     or    PRIMARY KEY (index_col_name,...)
  51     or    KEY [index_name] (index_col_name,...)
  52     or    INDEX [index_name] (index_col_name,...)
  53     or    UNIQUE [INDEX] [index_name] (index_col_name,...)
  54     or    FULLTEXT [INDEX] [index_name] (index_col_name,...)
  55     or    [CONSTRAINT symbol] FOREIGN KEY [index_name] (index_col_name,...)
  56               [reference_definition]
  57     or    CHECK (expr)
  58
  59   type:
  60           TINYINT[(length)] [UNSIGNED] [ZEROFILL]
  61     or    SMALLINT[(length)] [UNSIGNED] [ZEROFILL]
  62     or    MEDIUMINT[(length)] [UNSIGNED] [ZEROFILL]
  63     or    INT[(length)] [UNSIGNED] [ZEROFILL]
  64     or    INTEGER[(length)] [UNSIGNED] [ZEROFILL]
  65     or    BIGINT[(length)] [UNSIGNED] [ZEROFILL]
  66     or    REAL[(length,decimals)] [UNSIGNED] [ZEROFILL]
  67     or    DOUBLE[(length,decimals)] [UNSIGNED] [ZEROFILL]
  68     or    FLOAT[(length,decimals)] [UNSIGNED] [ZEROFILL]
  69     or    DECIMAL(length,decimals) [UNSIGNED] [ZEROFILL]
  70     or    NUMERIC(length,decimals) [UNSIGNED] [ZEROFILL]
  71     or    CHAR(length) [BINARY]
  72     or    VARCHAR(length) [BINARY]
  73     or    DATE
  74     or    TIME
  75     or    TIMESTAMP
  76     or    DATETIME
  77     or    TINYBLOB
  78     or    BLOB
  79     or    MEDIUMBLOB
  80     or    LONGBLOB
  81     or    TINYTEXT
  82     or    TEXT
  83     or    MEDIUMTEXT
  84     or    LONGTEXT
  85     or    ENUM(value1,value2,value3,...)
  86     or    SET(value1,value2,value3,...)
  87
  88   index_col_name:
  89           col_name [(length)]
  90
  91   reference_definition:
  92           REFERENCES tbl_name [(index_col_name,...)]
  93                      [MATCH FULL | MATCH PARTIAL]
  94                      [ON DELETE reference_option]
  95                      [ON UPDATE reference_option]
  96
  97   reference_option:
  98           RESTRICT | CASCADE | SET NULL | NO ACTION | SET DEFAULT
  99
 100   table_options:
 101           TYPE = {BDB | HEAP | ISAM | InnoDB | MERGE | MRG_MYISAM | MYISAM }
 102   or      ENGINE = {BDB | HEAP | ISAM | InnoDB | MERGE | MRG_MYISAM | MYISAM }
 103   or      AUTO_INCREMENT = #
 104   or      AVG_ROW_LENGTH = #
 105   or      [ DEFAULT ] CHARACTER SET charset_name
 106   or      CHECKSUM = {0 | 1}
 107   or      COLLATE collation_name
 108   or      COMMENT = "string"
 109   or      MAX_ROWS = #
 110   or      MIN_ROWS = #
 111   or      PACK_KEYS = {0 | 1 | DEFAULT}
 112   or      PASSWORD = "string"
 113   or      DELAY_KEY_WRITE = {0 | 1}
 114   or      ROW_FORMAT= { default | dynamic | fixed | compressed }
 115   or      RAID_TYPE= {1 | STRIPED | RAID0 } RAID_CHUNKS=#  RAID_CHUNKSIZE=#
 116   or      UNION = (table_name,[table_name...])
 117   or      INSERT_METHOD= {NO | FIRST | LAST }
 118   or      DATA DIRECTORY="absolute path to directory"
 119   or      INDEX DIRECTORY="absolute path to directory"
 120
 121
 122 A subset of the ALTER TABLE syntax that allows addition of foreign keys:
 123
 124   ALTER [IGNORE] TABLE tbl_name alter_specification [, alter_specification] ...
 125
 126   alter_specification:
 127           ADD [CONSTRAINT [symbol]]
 128           FOREIGN KEY [index_name] (index_col_name,...)
 129              [reference_definition]
 130
 131 A subset of INSERT that we ignore:
 132
 133   INSERT anything
 134
 135 =head1 ARGUMENTS
 136
 137 This parser takes a single optional parser_arg C<mysql_parser_version>, which
 138 provides the desired version for the target database. Any statement in the processed
 139 dump file, that is commented with a version higher than the one supplied, will be stripped.
 140
 141 Valid version specifiers for C<mysql_parser_version> are listed L<here|SQL::Translator::Utils/parse_mysql_version>
 142
 143 More information about the MySQL comment-syntax: L<http://dev.mysql.com/doc/refman/5.0/en/comments.html>
 144
 145
 146 =cut
 147
 148 use strict;
 149 use vars qw[ $DEBUG $VERSION $GRAMMAR @EXPORT_OK ];
 150 $VERSION = '1.59';
 151 $DEBUG   = 0 unless defined $DEBUG;
 152
 153 use Data::Dumper;
 154 use Parse::RecDescent;
 155 use Exporter;
 156 use Storable qw(dclone);
 157 use DBI qw(:sql_types);
 158 use base qw(Exporter);
 159
 160 use SQL::Translator::Utils qw/parse_mysql_version/;
 161
 162 our %type_mapping = ();
 163
 164 @EXPORT_OK = qw(parse);
 165
 166 # Enable warnings within the Parse::RecDescent module.
 167 $::RD_ERRORS = 1; # Make sure the parser dies when it encounters an error
 168 $::RD_WARN   = 1; # Enable warnings. This will warn on unused rules &c.
 169 $::RD_HINT   = 1; # Give out hints to help fix problems.
 170
 171 use constant DEFAULT_PARSER_VERSION => 30000;
 172
 173 $GRAMMAR = << 'END_OF_GRAMMAR';
 174
 175 {
 176     my ( $database_name, %tables, $table_order, @table_comments, %views,
 177         $view_order, %procedures, $proc_order );
 178     my $delimiter = ';';
 179 }
 180
 181 #
 182 # The "eofile" rule makes the parser fail if any "statement" rule
 183 # fails.  Otherwise, the first successful match by a "statement"
 184 # won't cause the failure needed to know that the parse, as a whole,
 185 # failed. -ky
 186 #
 187 startrule : statement(s) eofile {
 188     {
 189         database_name => $database_name,
 190         tables        => \%tables,
 191         views         => \%views,
 192         procedures    => \%procedures,
 193     }
 194 }
 195
 196 eofile : /^\Z/
 197
 198 statement : comment
 199     | use
 200     | set
 201     | drop
 202     | create
 203     | alter
 204     | insert
 205     | delimiter
 206     | empty_statement
 207     | <error>
 208
 209 use : /use/i WORD "$delimiter"
 210     {
 211         $database_name = $item[2];
 212         @table_comments = ();
 213     }
 214
 215 set : /set/i /[^;]+/ "$delimiter"
 216     { @table_comments = () }
 217
 218 drop : /drop/i TABLE /[^;]+/ "$delimiter"
 219
 220 drop : /drop/i WORD(s) "$delimiter"
 221     { @table_comments = () }
 222
 223 string :
 224   # MySQL strings, unlike common SQL strings, can be double-quoted or
 225   # single-quoted, and you can escape the delmiters by doubling (but only the
 226   # delimiter) or by backslashing.
 227
 228    /'(\\.|''|[^\\\'])*'/ |
 229    /"(\\.|""|[^\\\"])*"/
 230   # For reference, std sql str: /(?:(?:\')(?:[^\']*(?:(?:\'\')[^\']*)*)(?:\'))//
 231
 232 nonstring : /[^;\'"]+/
 233
 234 statement_body : (string | nonstring)(s?)
 235
 236 insert : /insert/i  statement_body "$delimiter"
 237
 238 delimiter : /delimiter/i /[\S]+/
 239     { $delimiter = $item[2] }
 240
 241 empty_statement : "$delimiter"
 242
 243 alter : ALTER TABLE table_name alter_specification(s /,/) "$delimiter"
 244     {
 245         my $table_name                       = $item{'table_name'};
 246     die "Cannot ALTER table '$table_name'; it does not exist"
 247         unless $tables{ $table_name };
 248         for my $definition ( @{ $item[4] } ) {
 249         $definition->{'extra'}->{'alter'} = 1;
 250         push @{ $tables{ $table_name }{'constraints'} }, $definition;
 251     }
 252     }
 253
 254 alter_specification : ADD foreign_key_def
 255     { $return = $item[2] }
 256
 257 create : CREATE /database/i WORD "$delimiter"
 258     { @table_comments = () }
 259
 260 create : CREATE TEMPORARY(?) TABLE opt_if_not_exists(?) table_name '(' create_definition(s /,/) /(,\s*)?\)/ table_option(s?) "$delimiter"
 261     {
 262         my $table_name                       = $item{'table_name'};
 263         $tables{ $table_name }{'order'}      = ++$table_order;
 264         $tables{ $table_name }{'table_name'} = $table_name;
 265
 266         if ( @table_comments ) {
 267             $tables{ $table_name }{'comments'} = [ @table_comments ];
 268             @table_comments = ();
 269         }
 270
 271         my $i = 1;
 272         for my $definition ( @{ $item[7] } ) {
 273             if ( $definition->{'supertype'} eq 'field' ) {
 274                 my $field_name = $definition->{'name'};
 275                 $tables{ $table_name }{'fields'}{ $field_name } =
 276                     { %$definition, order => $i };
 277                 $i++;
 278
 279                 if ( $definition->{'is_primary_key'} ) {
 280                     push @{ $tables{ $table_name }{'constraints'} },
 281                         {
 282                             type   => 'primary_key',
 283                             fields => [ $field_name ],
 284                         }
 285                     ;
 286                 }
 287             }
 288             elsif ( $definition->{'supertype'} eq 'constraint' ) {
 289                 push @{ $tables{ $table_name }{'constraints'} }, $definition;
 290             }
 291             elsif ( $definition->{'supertype'} eq 'index' ) {
 292                 push @{ $tables{ $table_name }{'indices'} }, $definition;
 293             }
 294         }
 295
 296         if ( my @options = @{ $item{'table_option(s?)'} } ) {
 297             for my $option ( @options ) {
 298                 my ( $key, $value ) = each %$option;
 299                 if ( $key eq 'comment' ) {
 300                     push @{ $tables{ $table_name }{'comments'} }, $value;
 301                 }
 302                 else {
 303                     push @{ $tables{ $table_name }{'table_options'} }, $option;
 304                 }
 305             }
 306         }
 307
 308         1;
 309     }
 310
 311 opt_if_not_exists : /if not exists/i
 312
 313 create : CREATE UNIQUE(?) /(index|key)/i index_name /on/i table_name '(' field_name(s /,/) ')' "$delimiter"
 314     {
 315         @table_comments = ();
 316         push @{ $tables{ $item{'table_name'} }{'indices'} },
 317             {
 318                 name   => $item[4],
 319                 type   => $item[2][0] ? 'unique' : 'normal',
 320                 fields => $item[8],
 321             }
 322         ;
 323     }
 324
 325 create : CREATE /trigger/i NAME not_delimiter "$delimiter"
 326     {
 327         @table_comments = ();
 328     }
 329
 330 create : CREATE PROCEDURE NAME not_delimiter "$delimiter"
 331     {
 332         @table_comments = ();
 333         my $func_name = $item[3];
 334         my $owner = '';
 335         my $sql = "$item[1] $item[2] $item[3] $item[4]";
 336
 337         $procedures{ $func_name }{'order'}  = ++$proc_order;
 338         $procedures{ $func_name }{'name'}   = $func_name;
 339         $procedures{ $func_name }{'owner'}  = $owner;
 340         $procedures{ $func_name }{'sql'}    = $sql;
 341     }
 342
 343 PROCEDURE : /procedure/i
 344     | /function/i
 345
 346 create : CREATE algorithm(?) /view/i NAME not_delimiter "$delimiter"
 347     {
 348         @table_comments = ();
 349         my $view_name = $item[4];
 350         my $sql;
 351         if (scalar(@{$item[2]}) == 1) {
 352                 $sql = "$item[1] $item[2][0] $item[3] $item[4] $item[5]";
 353         } else {
 354             $sql = "$item[1] $item[3] $item[4] $item[5]";
 355         }
 356
 357         # Hack to strip database from function calls in SQL
 358         $sql =~ s#`\w+`\.(`\w+`\()##g;
 359
 360         $views{ $view_name }{'order'}  = ++$view_order;
 361         $views{ $view_name }{'name'}   = $view_name;
 362         $views{ $view_name }{'sql'}    = $sql;
 363     }
 364
 365 algorithm : /algorithm/i /=/ WORD
 366     {
 367         $return = "$item[1]=$item[3]";
 368     }
 369
 370 not_delimiter : /.*?(?=$delimiter)/is
 371
 372 create_definition : constraint
 373     | index
 374     | field
 375     | comment
 376     | <error>
 377
 378 comment : /^\s*(?:#|-{2}).*\n/
 379     {
 380         my $comment =  $item[1];
 381         $comment    =~ s/^\s*(#|--)\s*//;
 382         $comment    =~ s/\s*$//;
 383         $return     = $comment;
 384     }
 385
 386 comment : /\/\*/ /.*?\*\//s
 387     {
 388         my $comment = $item[2];
 389         $comment = substr($comment, 0, -2);
 390         $comment    =~ s/^\s*|\s*$//g;
 391         $return = $comment;
 392     }
 393
 394 field_comment : /^\s*(?:#|-{2}).*\n/
 395     {
 396         my $comment =  $item[1];
 397         $comment    =~ s/^\s*(#|--)\s*//;
 398         $comment    =~ s/\s*$//;
 399         $return     = $comment;
 400     }
 401
 402
 403 field_comment2 : /comment/i /'.*?'/
 404     {
 405         my $comment = $item[2];
 406         $comment    =~ s/^'//;
 407         $comment    =~ s/'$//;
 408         $return     = $comment;
 409     }
 410
 411 blank : /\s*/
 412
 413 field : field_comment(s?) field_name data_type field_qualifier(s?) field_comment2(?) reference_definition(?) on_update(?) field_comment(s?)
 414     {
 415         my %qualifiers  = map { %$_ } @{ $item{'field_qualifier(s?)'} || [] };
 416         if ( my @type_quals = @{ $item{'data_type'}{'qualifiers'} || [] } ) {
 417             $qualifiers{ $_ } = 1 for @type_quals;
 418         }
 419
 420         my $null = defined $qualifiers{'not_null'}
 421                    ? $qualifiers{'not_null'} : 1;
 422         delete $qualifiers{'not_null'};
 423
 424         my @comments = ( @{ $item[1] }, @{ $item[5] }, @{ $item[8] } );
 425
 426         $return = {
 427             supertype   => 'field',
 428             name        => $item{'field_name'},
 429             data_type   => $item{'data_type'}{'type'},
 430             size        => $item{'data_type'}{'size'},
 431             list        => $item{'data_type'}{'list'},
 432             null        => $null,
 433             constraints => $item{'reference_definition(?)'},
 434             comments    => [ @comments ],
 435             %qualifiers,
 436         }
 437     }
 438     | <error>
 439
 440 field_qualifier : not_null
 441     {
 442         $return = {
 443              null => $item{'not_null'},
 444         }
 445     }
 446
 447 field_qualifier : default_val
 448     {
 449         $return = {
 450              default => $item{'default_val'},
 451         }
 452     }
 453
 454 field_qualifier : auto_inc
 455     {
 456         $return = {
 457              is_auto_inc => $item{'auto_inc'},
 458         }
 459     }
 460
 461 field_qualifier : primary_key
 462     {
 463         $return = {
 464              is_primary_key => $item{'primary_key'},
 465         }
 466     }
 467
 468 field_qualifier : unsigned
 469     {
 470         $return = {
 471              is_unsigned => $item{'unsigned'},
 472         }
 473     }
 474
 475 field_qualifier : /character set/i WORD
 476     {
 477         $return = {
 478             'CHARACTER SET' => $item[2],
 479         }
 480     }
 481
 482 field_qualifier : /collate/i WORD
 483     {
 484         $return = {
 485             COLLATE => $item[2],
 486         }
 487     }
 488
 489 field_qualifier : /on update/i CURRENT_TIMESTAMP
 490     {
 491         $return = {
 492             'ON UPDATE' => $item[2],
 493         }
 494     }
 495
 496 field_qualifier : /unique/i KEY(?)
 497     {
 498         $return = {
 499             is_unique => 1,
 500         }
 501     }
 502
 503 field_qualifier : KEY
 504     {
 505         $return = {
 506             has_index => 1,
 507         }
 508     }
 509
 510 reference_definition : /references/i table_name parens_field_list(?) match_type(?) on_delete(?) on_update(?)
 511     {
 512         $return = {
 513             type             => 'foreign_key',
 514             reference_table  => $item[2],
 515             reference_fields => $item[3][0],
 516             match_type       => $item[4][0],
 517             on_delete        => $item[5][0],
 518             on_update        => $item[6][0],
 519         }
 520     }
 521
 522 match_type : /match full/i { 'full' }
 523     |
 524     /match partial/i { 'partial' }
 525
 526 on_delete : /on delete/i reference_option
 527     { $item[2] }
 528
 529 on_update :
 530     /on update/i 'CURRENT_TIMESTAMP'
 531     { $item[2] }
 532     |
 533     /on update/i reference_option
 534     { $item[2] }
 535
 536 reference_option: /restrict/i |
 537     /cascade/i   |
 538     /set null/i  |
 539     /no action/i |
 540     /set default/i
 541     { $item[1] }
 542
 543 index : normal_index
 544     | fulltext_index
 545     | spatial_index
 546     | <error>
 547
 548 table_name   : NAME
 549
 550 field_name   : NAME
 551
 552 index_name   : NAME
 553
 554 data_type    : WORD parens_value_list(s?) type_qualifier(s?)
 555     {
 556         my $type = $item[1];
 557         my $size; # field size, applicable only to non-set fields
 558         my $list; # set list, applicable only to sets (duh)
 559
 560         if ( uc($type) =~ /^(SET|ENUM)$/ ) {
 561             $size = undef;
 562             $list = $item[2][0];
 563         }
 564         else {
 565             $size = $item[2][0];
 566             $list = [];
 567         }
 568
 569
 570         $return        = {
 571             type       => $type,
 572             size       => $size,
 573             list       => $list,
 574             qualifiers => $item[3],
 575         }
 576     }
 577
 578 parens_field_list : '(' field_name(s /,/) ')'
 579     { $item[2] }
 580
 581 parens_value_list : '(' VALUE(s /,/) ')'
 582     { $item[2] }
 583
 584 type_qualifier : /(BINARY|UNSIGNED|ZEROFILL)/i
 585     { lc $item[1] }
 586
 587 field_type   : WORD
 588
 589 create_index : /create/i /index/i
 590
 591 not_null     : /not/i /null/i
 592     { $return = 0 }
 593     |
 594     /null/i
 595     { $return = 1 }
 596
 597 unsigned     : /unsigned/i { $return = 0 }
 598
 599 #default_val  : /default/i /(?:')?[\s\w\d:.-]*(?:')?/
 600 #    {
 601 #        $item[2] =~ s/'//g;
 602 #        $return  =  $item[2];
 603 #    }
 604
 605 default_val :
 606     /default/i 'CURRENT_TIMESTAMP'
 607     {
 608         $return =  \$item[2];
 609     }
 610     |
 611     /default/i /'(?:.*?\\')*.*?'|(?:')?[\w\d:.-]*(?:')?/
 612     {
 613         $item[2] =~ s/^\s*'|'\s*$//g;
 614         $return  =  $item[2];
 615     }
 616
 617 auto_inc : /auto_increment/i { 1 }
 618
 619 primary_key : /primary/i /key/i { 1 }
 620
 621 constraint : primary_key_def
 622     | unique_key_def
 623     | foreign_key_def
 624     | <error>
 625
 626 foreign_key_def : foreign_key_def_begin parens_field_list reference_definition
 627     {
 628         $return              =  {
 629             supertype        => 'constraint',
 630             type             => 'foreign_key',
 631             name             => $item[1],
 632             fields           => $item[2],
 633             %{ $item{'reference_definition'} },
 634         }
 635     }
 636
 637 foreign_key_def_begin : /constraint/i /foreign key/i WORD
 638     { $return = $item[3] }
 639     |
 640     /constraint/i NAME /foreign key/i
 641     { $return = $item[2] }
 642     |
 643     /constraint/i /foreign key/i
 644     { $return = '' }
 645     |
 646     /foreign key/i WORD
 647     { $return = $item[2] }
 648     |
 649     /foreign key/i
 650     { $return = '' }
 651
 652 primary_key_def : primary_key index_name(?) '(' name_with_opt_paren(s /,/) ')'
 653     {
 654         $return       = {
 655             supertype => 'constraint',
 656             name      => $item{'index_name(?)'}[0],
 657             type      => 'primary_key',
 658             fields    => $item[4],
 659         };
 660     }
 661
 662 unique_key_def : UNIQUE KEY(?) index_name(?) '(' name_with_opt_paren(s /,/) ')'
 663     {
 664         $return       = {
 665             supertype => 'constraint',
 666             name      => $item{'index_name(?)'}[0],
 667             type      => 'unique',
 668             fields    => $item[5],
 669         }
 670     }
 671
 672 normal_index : KEY index_name(?) '(' name_with_opt_paren(s /,/) ')'
 673     {
 674         $return       = {
 675             supertype => 'index',
 676             type      => 'normal',
 677             name      => $item{'index_name(?)'}[0],
 678             fields    => $item[4],
 679         }
 680     }
 681
 682 fulltext_index : /fulltext/i KEY(?) index_name(?) '(' name_with_opt_paren(s /,/) ')'
 683     {
 684         $return       = {
 685             supertype => 'index',
 686             type      => 'fulltext',
 687             name      => $item{'index_name(?)'}[0],
 688             fields    => $item[5],
 689         }
 690     }
 691
 692 spatial_index : /spatial/i KEY(?) index_name(?) '(' name_with_opt_paren(s /,/) ')'
 693     {
 694         $return       = {
 695             supertype => 'index',
 696             type      => 'spatial',
 697             name      => $item{'index_name(?)'}[0],
 698             fields    => $item[5],
 699         }
 700     }
 701
 702 name_with_opt_paren : NAME parens_value_list(s?)
 703     { $item[2][0] ? "$item[1]($item[2][0][0])" : $item[1] }
 704
 705 UNIQUE : /unique/i
 706
 707 KEY : /key/i | /index/i
 708
 709 table_option : /comment/i /=/ /'.*?'/
 710     {
 711         my $comment = $item[3];
 712         $comment    =~ s/^'//;
 713         $comment    =~ s/'$//;
 714         $return     = { comment => $comment };
 715     }
 716     | /(default )?(charset|character set)/i /\s*=?\s*/ WORD
 717     {
 718         $return = { 'CHARACTER SET' => $item[3] };
 719     }
 720     | /collate/i WORD
 721     {
 722         $return = { 'COLLATE' => $item[2] }
 723     }
 724     | /union/i /\s*=\s*/ '(' table_name(s /,/) ')'
 725     {
 726         $return = { $item[1] => $item[4] };
 727     }
 728     | WORD /\s*=\s*/ MAYBE_QUOTED_WORD
 729     {
 730         $return = { $item[1] => $item[3] };
 731     }
 732
 733 MAYBE_QUOTED_WORD: /\w+/
 734                  | /'(\w+)'/
 735                  { $return = $1 }
 736                  | /"(\w+)"/
 737                  { $return = $1 }
 738
 739 default : /default/i
 740
 741 ADD : /add/i
 742
 743 ALTER : /alter/i
 744
 745 CREATE : /create/i
 746
 747 TEMPORARY : /temporary/i
 748
 749 TABLE : /table/i
 750
 751 WORD : /\w+/
 752
 753 DIGITS : /\d+/
 754
 755 COMMA : ','
 756
 757 BACKTICK : '`'
 758
 759 DOUBLE_QUOTE: '"'
 760
 761 NAME    : BACKTICK /[^`]+/ BACKTICK
 762     { $item[2] }
 763     | DOUBLE_QUOTE /[^"]+/ DOUBLE_QUOTE
 764     { $item[2] }
 765     | /\w+/
 766     { $item[1] }
 767
 768 VALUE   : /[-+]?\.?\d+(?:[eE]\d+)?/
 769     { $item[1] }
 770     | /'.*?'/
 771     {
 772         # remove leading/trailing quotes
 773         my $val = $item[1];
 774         $val    =~ s/^['"]|['"]$//g;
 775         $return = $val;
 776     }
 777     | /NULL/
 778     { 'NULL' }
 779
 780 CURRENT_TIMESTAMP : /current_timestamp(\(\))?/i
 781     | /now\(\)/i
 782     { 'CURRENT_TIMESTAMP' }
 783
 784 END_OF_GRAMMAR
 785
 786 # -------------------------------------------------------------------
 787 sub parse {
 788     my ( $translator, $data ) = @_;
 789     my $parser = Parse::RecDescent->new($GRAMMAR);
 790     local $::RD_TRACE  = $translator->trace ? 1 : undef;
 791     local $DEBUG       = $translator->debug;
 792
 793     unless (defined $parser) {
 794         return $translator->error("Error instantiating Parse::RecDescent ".
 795             "instance: Bad grammer");
 796     }
 797
 798     # Preprocess for MySQL-specific and not-before-version comments
 799     # from mysqldump
 800     my $parser_version = parse_mysql_version(
 801         $translator->parser_args->{mysql_parser_version}, 'mysql'
 802     ) || DEFAULT_PARSER_VERSION;
 803
 804     while ( $data =~
 805         s#/\*!(\d{5})?(.*?)\*/#($1 && $1 > $parser_version ? '' : $2)#es
 806     ) {
 807         # do nothing; is there a better way to write this? -- ky
 808     }
 809
 810     my $result = $parser->startrule($data);
 811     return $translator->error( "Parse failed." ) unless defined $result;
 812     warn "Parse result:".Dumper( $result ) if $DEBUG;
 813
 814     my $schema = $translator->schema;
 815     $schema->name($result->{'database_name'}) if $result->{'database_name'};
 816
 817     my @tables = sort {
 818         $result->{'tables'}{ $a }{'order'}
 819         <=>
 820         $result->{'tables'}{ $b }{'order'}
 821     } keys %{ $result->{'tables'} };
 822
 823     for my $table_name ( @tables ) {
 824         my $tdata =  $result->{tables}{ $table_name };
 825         my $table =  $schema->add_table(
 826             name  => $tdata->{'table_name'},
 827         ) or die $schema->error;
 828
 829         $table->comments( $tdata->{'comments'} );
 830
 831         my @fields = sort {
 832             $tdata->{'fields'}->{$a}->{'order'}
 833             <=>
 834             $tdata->{'fields'}->{$b}->{'order'}
 835         } keys %{ $tdata->{'fields'} };
 836
 837         for my $fname ( @fields ) {
 838             my $fdata = $tdata->{'fields'}{ $fname };
 839             my $field = $table->add_field(
 840                 name              => $fdata->{'name'},
 841                 data_type         => $fdata->{'data_type'},
 842                 size              => $fdata->{'size'},
 843                 default_value     => $fdata->{'default'},
 844                 is_auto_increment => $fdata->{'is_auto_inc'},
 845                 is_nullable       => $fdata->{'null'},
 846                 comments          => $fdata->{'comments'},
 847             ) or die $table->error;
 848
 849             $table->primary_key( $field->name ) if $fdata->{'is_primary_key'};
 850
 851             for my $qual ( qw[ binary unsigned zerofill list collate ],
 852                     'character set', 'on update' ) {
 853                 if ( my $val = $fdata->{ $qual } || $fdata->{ uc $qual } ) {
 854                     next if ref $val eq 'ARRAY' && !@$val;
 855                     $field->extra( $qual, $val );
 856                 }
 857             }
 858
 859             if ( $fdata->{'has_index'} ) {
 860                 $table->add_index(
 861                     name   => '',
 862                     type   => 'NORMAL',
 863                     fields => $fdata->{'name'},
 864                 ) or die $table->error;
 865             }
 866
 867             if ( $fdata->{'is_unique'} ) {
 868                 $table->add_constraint(
 869                     name   => '',
 870                     type   => 'UNIQUE',
 871                     fields => $fdata->{'name'},
 872                 ) or die $table->error;
 873             }
 874
 875             for my $cdata ( @{ $fdata->{'constraints'} } ) {
 876                 next unless $cdata->{'type'} eq 'foreign_key';
 877                 $cdata->{'fields'} ||= [ $field->name ];
 878                 push @{ $tdata->{'constraints'} }, $cdata;
 879             }
 880
 881         }
 882
 883         for my $idata ( @{ $tdata->{'indices'} || [] } ) {
 884             my $index  =  $table->add_index(
 885                 name   => $idata->{'name'},
 886                 type   => uc $idata->{'type'},
 887                 fields => $idata->{'fields'},
 888             ) or die $table->error;
 889         }
 890
 891         if ( my @options = @{ $tdata->{'table_options'} || [] } ) {
 892             my @cleaned_options;
 893             my @ignore_opts = $translator->parser_args->{'ignore_opts'}
 894                 ? split( /,/, $translator->parser_args->{'ignore_opts'} )
 895                 : ();
 896             if (@ignore_opts) {
 897                 my $ignores = { map { $_ => 1 } @ignore_opts };
 898                 foreach my $option (@options) {
 899                     # make sure the option isn't in ignore list
 900                     my ($option_key) = keys %$option;
 901                     if ( !exists $ignores->{$option_key} ) {
 902                         push @cleaned_options, $option;
 903                     }
 904                 }
 905             } else {
 906                 @cleaned_options = @options;
 907             }
 908             $table->options( \@cleaned_options ) or die $table->error;
 909         }
 910
 911         for my $cdata ( @{ $tdata->{'constraints'} || [] } ) {
 912             my $constraint       =  $table->add_constraint(
 913                 name             => $cdata->{'name'},
 914                 type             => $cdata->{'type'},
 915                 fields           => $cdata->{'fields'},
 916                 reference_table  => $cdata->{'reference_table'},
 917                 reference_fields => $cdata->{'reference_fields'},
 918                 match_type       => $cdata->{'match_type'} || '',
 919                 on_delete        => $cdata->{'on_delete'}
 920                                  || $cdata->{'on_delete_do'},
 921                 on_update        => $cdata->{'on_update'}
 922                                  || $cdata->{'on_update_do'},
 923             ) or die $table->error;
 924         }
 925
 926         # After the constrains and PK/idxs have been created,
 927         # we normalize fields
 928         normalize_field($_) for $table->get_fields;
 929     }
 930
 931     my @procedures = sort {
 932         $result->{procedures}->{ $a }->{'order'}
 933         <=>
 934         $result->{procedures}->{ $b }->{'order'}
 935     } keys %{ $result->{procedures} };
 936
 937     for my $proc_name ( @procedures ) {
 938         $schema->add_procedure(
 939             name  => $proc_name,
 940             owner => $result->{procedures}->{$proc_name}->{owner},
 941             sql   => $result->{procedures}->{$proc_name}->{sql},
 942         );
 943     }
 944
 945     my @views = sort {
 946         $result->{views}->{ $a }->{'order'}
 947         <=>
 948         $result->{views}->{ $b }->{'order'}
 949     } keys %{ $result->{views} };
 950
 951     for my $view_name ( keys %{ $result->{'views'} } ) {
 952         $schema->add_view(
 953             name => $view_name,
 954             sql  => $result->{'views'}->{$view_name}->{sql},
 955         );
 956     }
 957
 958     return 1;
 959 }
 960
 961 # Takes a field, and returns
 962 sub normalize_field {
 963     my ($field) = @_;
 964     my ($size, $type, $list, $changed) = @_;
 965
 966     $size = $field->size;
 967     $type = $field->data_type;
 968     $list = $field->extra->{list} || [];
 969
 970     if ( !ref $size && $size eq 0 ) {
 971         if ( lc $type eq 'tinyint' ) {
 972             $changed = $size != 4;
 973             $size = 4;
 974         }
 975         elsif ( lc $type eq 'smallint' ) {
 976             $changed = $size != 6;
 977             $size = 6;
 978         }
 979         elsif ( lc $type eq 'mediumint' ) {
 980             $changed = $size != 9;
 981             $size = 9;
 982         }
 983         elsif ( $type =~ /^int(eger)?$/i ) {
 984             $changed = $size != 11 || $type ne 'int';
 985             $type = 'int';
 986             $size = 11;
 987         }
 988         elsif ( lc $type eq 'bigint' ) {
 989             $changed = $size != 20;
 990             $size = 20;
 991         }
 992         elsif ( lc $type =~ /(float|double|decimal|numeric|real|fixed|dec)/ ) {
 993             my $old_size = (ref $size || '') eq 'ARRAY' ? $size : [];
 994             $changed     = @$old_size != 2
 995                         || $old_size->[0] != 8
 996                         || $old_size->[1] != 2;
 997             $size        = [8,2];
 998         }
 999     }
1000
1001     if ( $type =~ /^tiny(text|blob)$/i ) {
1002         $changed = $size != 255;
1003         $size = 255;
1004     }
1005     elsif ( $type =~ /^(blob|text)$/i ) {
1006         $changed = $size != 65_535;
1007         $size = 65_535;
1008     }
1009     elsif ( $type =~ /^medium(blob|text)$/i ) {
1010         $changed = $size != 16_777_215;
1011         $size = 16_777_215;
1012     }
1013     elsif ( $type =~ /^long(blob|text)$/i ) {
1014         $changed = $size != 4_294_967_295;
1015         $size = 4_294_967_295;
1016     }
1017
1018     if ( $field->data_type =~ /(set|enum)/i && !$field->size ) {
1019         my %extra = $field->extra;
1020         my $longest = 0;
1021         for my $len ( map { length } @{ $extra{'list'} || [] } ) {
1022             $longest = $len if $len > $longest;
1023         }
1024         $changed = 1;
1025         $size = $longest if $longest;
1026     }
1027
1028
1029     if ( $changed ) {
1030         # We only want to clone the field, not *everything*
1031         {
1032             local $field->{table} = undef;
1033             $field->parsed_field( dclone( $field ) );
1034             $field->parsed_field->{table} = $field->table;
1035         }
1036         $field->size( $size );
1037         $field->data_type( $type );
1038         $field->sql_data_type( $type_mapping{ lc $type } )
1039             if exists $type_mapping{ lc $type };
1040         $field->extra->{list} = $list if @$list;
1041     }
1042 }
1043
1044 1;
1045
1046 # -------------------------------------------------------------------
1047 # Where man is not nature is barren.
1048 # William Blake
1049 # -------------------------------------------------------------------
1050
1051 =pod
1052
1053 =head1 AUTHOR
1054
1055 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>,
1056 Chris Mungall E<lt>cjm@fruitfly.orgE<gt>.
1057
1058 =head1 SEE ALSO
1059
1060 Parse::RecDescent, SQL::Translator::Schema.
1061
1062 =cut