lib/SQL/Translator/Parser/MySQL.pm

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