lib/SQL/Translator/Parser/MySQL.pm

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