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 The default C<mysql_parser_version> is set to the conservative value of 40000 (MySQL 4.0)
 124
 125 Valid version specifiers for C<mysql_parser_version> are listed L<here|SQL::Translator::Utils/parse_mysql_version>
 126
 127 More information about the MySQL comment-syntax: L<http://dev.mysql.com/doc/refman/5.0/en/comments.html>
 128
 129
 130 =cut
 131
 132 use strict;
 133 use warnings;
 134
 135 our $VERSION = '1.59';
 136
 137 our $DEBUG;
 138 $DEBUG   = 0 unless defined $DEBUG;
 139
 140 use Data::Dumper;
 141 use Storable qw(dclone);
 142 use DBI qw(:sql_types);
 143 use SQL::Translator::Utils qw/parse_mysql_version ddl_parser_instance/;
 144
 145 use base qw(Exporter);
 146 our @EXPORT_OK = qw(parse);
 147
 148 our %type_mapping = ();
 149
 150 use constant DEFAULT_PARSER_VERSION => 40000;
 151
 152 our $GRAMMAR = << 'END_OF_GRAMMAR';
 153
 154 {
 155     my ( $database_name, %tables, $table_order, @table_comments, %views,
 156         $view_order, %procedures, $proc_order );
 157     my $delimiter = ';';
 158 }
 159
 160 #
 161 # The "eofile" rule makes the parser fail if any "statement" rule
 162 # fails.  Otherwise, the first successful match by a "statement"
 163 # won't cause the failure needed to know that the parse, as a whole,
 164 # failed. -ky
 165 #
 166 startrule : statement(s) eofile {
 167     {
 168         database_name => $database_name,
 169         tables        => \%tables,
 170         views         => \%views,
 171         procedures    => \%procedures,
 172     }
 173 }
 174
 175 eofile : /^\Z/
 176
 177 statement : comment
 178     | use
 179     | set
 180     | drop
 181     | create
 182     | alter
 183     | insert
 184     | delimiter
 185     | empty_statement
 186     | <error>
 187
 188 use : /use/i WORD "$delimiter"
 189     {
 190         $database_name = $item[2];
 191         @table_comments = ();
 192     }
 193
 194 set : /set/i not_delimiter "$delimiter"
 195     { @table_comments = () }
 196
 197 drop : /drop/i TABLE not_delimiter "$delimiter"
 198
 199 drop : /drop/i WORD(s) "$delimiter"
 200     { @table_comments = () }
 201
 202 bit:
 203     /(b'[01]{1,64}')/ |
 204     /(b"[01]{1,64}")/
 205
 206 string :
 207   # MySQL strings, unlike common SQL strings, can be double-quoted or
 208   # single-quoted, and you can escape the delmiters by doubling (but only the
 209   # delimiter) or by backslashing.
 210
 211    /'(\\.|''|[^\\\'])*'/ |
 212    /"(\\.|""|[^\\\"])*"/
 213   # For reference, std sql str: /(?:(?:\')(?:[^\']*(?:(?:\'\')[^\']*)*)(?:\'))//
 214
 215 nonstring : /[^;\'"]+/
 216
 217 statement_body : string | nonstring
 218
 219 insert : /insert/i  statement_body(s?) "$delimiter"
 220
 221 delimiter : /delimiter/i /[\S]+/
 222     { $delimiter = $item[2] }
 223
 224 empty_statement : "$delimiter"
 225
 226 alter : ALTER TABLE table_name alter_specification(s /,/) "$delimiter"
 227     {
 228         my $table_name                       = $item{'table_name'};
 229     die "Cannot ALTER table '$table_name'; it does not exist"
 230         unless $tables{ $table_name };
 231         for my $definition ( @{ $item[4] } ) {
 232         $definition->{'extra'}->{'alter'} = 1;
 233         push @{ $tables{ $table_name }{'constraints'} }, $definition;
 234     }
 235     }
 236
 237 alter_specification : ADD foreign_key_def
 238     { $return = $item[2] }
 239
 240 create : CREATE /database/i WORD "$delimiter"
 241     { @table_comments = () }
 242
 243 create : CREATE TEMPORARY(?) TABLE opt_if_not_exists(?) table_name '(' create_definition(s /,/) /(,\s*)?\)/ table_option(s?) "$delimiter"
 244     {
 245         my $table_name                       = $item{'table_name'};
 246         die "There is more than one definition for $table_name"
 247             if ($tables{$table_name});
 248
 249         $tables{ $table_name }{'order'}      = ++$table_order;
 250         $tables{ $table_name }{'table_name'} = $table_name;
 251
 252         if ( @table_comments ) {
 253             $tables{ $table_name }{'comments'} = [ @table_comments ];
 254             @table_comments = ();
 255         }
 256
 257         my $i = 1;
 258         for my $definition ( @{ $item[7] } ) {
 259             if ( $definition->{'supertype'} eq 'field' ) {
 260                 my $field_name = $definition->{'name'};
 261                 $tables{ $table_name }{'fields'}{ $field_name } =
 262                     { %$definition, order => $i };
 263                 $i++;
 264
 265                 if ( $definition->{'is_primary_key'} ) {
 266                     push @{ $tables{ $table_name }{'constraints'} },
 267                         {
 268                             type   => 'primary_key',
 269                             fields => [ $field_name ],
 270                         }
 271                     ;
 272                 }
 273             }
 274             elsif ( $definition->{'supertype'} eq 'constraint' ) {
 275                 push @{ $tables{ $table_name }{'constraints'} }, $definition;
 276             }
 277             elsif ( $definition->{'supertype'} eq 'index' ) {
 278                 push @{ $tables{ $table_name }{'indices'} }, $definition;
 279             }
 280         }
 281
 282         if ( my @options = @{ $item{'table_option(s?)'} } ) {
 283             for my $option ( @options ) {
 284                 my ( $key, $value ) = each %$option;
 285                 if ( $key eq 'comment' ) {
 286                     push @{ $tables{ $table_name }{'comments'} }, $value;
 287                 }
 288                 else {
 289                     push @{ $tables{ $table_name }{'table_options'} }, $option;
 290                 }
 291             }
 292         }
 293
 294         1;
 295     }
 296
 297 opt_if_not_exists : /if not exists/i
 298
 299 create : CREATE UNIQUE(?) /(index|key)/i index_name /on/i table_name '(' field_name(s /,/) ')' "$delimiter"
 300     {
 301         @table_comments = ();
 302         push @{ $tables{ $item{'table_name'} }{'indices'} },
 303             {
 304                 name   => $item[4],
 305                 type   => $item[2][0] ? 'unique' : 'normal',
 306                 fields => $item[8],
 307             }
 308         ;
 309     }
 310
 311 create : CREATE /trigger/i NAME not_delimiter "$delimiter"
 312     {
 313         @table_comments = ();
 314     }
 315
 316 create : CREATE PROCEDURE NAME not_delimiter "$delimiter"
 317     {
 318         @table_comments = ();
 319         my $func_name = $item[3];
 320         my $owner = '';
 321         my $sql = "$item[1] $item[2] $item[3] $item[4]";
 322
 323         $procedures{ $func_name }{'order'}  = ++$proc_order;
 324         $procedures{ $func_name }{'name'}   = $func_name;
 325         $procedures{ $func_name }{'owner'}  = $owner;
 326         $procedures{ $func_name }{'sql'}    = $sql;
 327     }
 328
 329 PROCEDURE : /procedure/i
 330     | /function/i
 331
 332 create : CREATE or_replace(?) create_view_option(s?) /view/i NAME /as/i view_select_statement "$delimiter"
 333     {
 334         @table_comments = ();
 335         my $view_name   = $item{'NAME'};
 336         my $select_sql  = $item{'view_select_statement'};
 337         my $options     = $item{'create_view_option(s?)'};
 338
 339         my $sql = join(q{ },
 340             grep { defined and length }
 341             map  { ref $_ eq 'ARRAY' ? @$_ : $_ }
 342             $item{'CREATE'},
 343             $item{'or_replace(?)'},
 344             $options,
 345             $view_name,
 346             'as select',
 347             join(', ',
 348                 map {
 349                     sprintf('%s%s',
 350                         $_->{'name'},
 351                         $_->{'alias'} ? ' as ' . $_->{'alias'} : ''
 352                     )
 353                 }
 354                 @{ $select_sql->{'columns'} || [] }
 355             ),
 356             ' from ',
 357             join(', ',
 358                 map {
 359                     sprintf('%s%s',
 360                         $_->{'name'},
 361                         $_->{'alias'} ? ' as ' . $_->{'alias'} : ''
 362                     )
 363                 }
 364                 @{ $select_sql->{'from'}{'tables'} || [] }
 365             ),
 366             $select_sql->{'from'}{'where'}
 367                 ? 'where ' . $select_sql->{'from'}{'where'}
 368                 : ''
 369             ,
 370         );
 371
 372         # Hack to strip database from function calls in SQL
 373         $sql =~ s#`\w+`\.(`\w+`\()##g;
 374
 375         $views{ $view_name }{'order'}   = ++$view_order;
 376         $views{ $view_name }{'name'}    = $view_name;
 377         $views{ $view_name }{'sql'}     = $sql;
 378         $views{ $view_name }{'options'} = $options;
 379         $views{ $view_name }{'select'}  = $item{'view_select_statement'};
 380     }
 381
 382 create_view_option : view_algorithm | view_sql_security | view_definer
 383
 384 or_replace : /or replace/i
 385
 386 view_algorithm : /algorithm/i /=/ WORD
 387     {
 388         $return = "$item[1]=$item[3]";
 389     }
 390
 391 view_definer : /definer=\S+/i
 392
 393 view_sql_security : /sql \s+ security  \s+ (definer|invoker)/ixs
 394
 395 not_delimiter : /.*?(?=$delimiter)/is
 396
 397 view_select_statement : /[(]?/ /select/i view_column_def /from/i view_table_def /[)]?/
 398     {
 399         $return = {
 400             columns => $item{'view_column_def'},
 401             from    => $item{'view_table_def'},
 402         };
 403     }
 404
 405 view_column_def : /(.*?)(?=\bfrom\b)/ixs
 406     {
 407         # split on commas not in parens,
 408         # e.g., "concat_ws(\' \', first, last) as first_last"
 409         my @tmp = $1 =~ /((?:[^(,]+|\(.*?\))+)/g;
 410         my @cols;
 411         for my $col ( @tmp ) {
 412             my ( $name, $alias ) = map {
 413               s/^\s+|\s+$//g;
 414               s/[`]//g;
 415               $_
 416             } split /\s+as\s+/i, $col;
 417
 418             push @cols, { name => $name, alias => $alias || '' };
 419         }
 420
 421         $return = \@cols;
 422     }
 423
 424 not_delimiter : /.*?(?=$delimiter)/is
 425
 426 view_table_def : not_delimiter
 427     {
 428         my $clause = $item[1];
 429         my $where  = $1 if $clause =~ s/\bwhere \s+ (.*)//ixs;
 430         $clause    =~ s/[)]\s*$//;
 431
 432         my @tables;
 433         for my $tbl ( split( /\s*,\s*/, $clause ) ) {
 434             my ( $name, $alias ) = split /\s+as\s+/i, $tbl;
 435             push @tables, { name => $name, alias => $alias || '' };
 436         }
 437
 438         $return = {
 439             tables => \@tables,
 440             where  => $where || '',
 441         };
 442     }
 443
 444 view_column_alias : /as/i WORD
 445     { $return = $item[2] }
 446
 447 create_definition : constraint
 448     | index
 449     | field
 450     | comment
 451     | <error>
 452
 453 comment : /^\s*(?:#|-{2}).*\n/
 454     {
 455         my $comment =  $item[1];
 456         $comment    =~ s/^\s*(#|--)\s*//;
 457         $comment    =~ s/\s*$//;
 458         $return     = $comment;
 459     }
 460
 461 comment : m{ / \* (?! \!) .*? \* / }xs
 462     {
 463         my $comment = $item[2];
 464         $comment = substr($comment, 0, -2);
 465         $comment    =~ s/^\s*|\s*$//g;
 466         $return = $comment;
 467     }
 468
 469 comment_like_command : m{/\*!(\d+)?}s
 470
 471 comment_end : m{ \* / }xs
 472
 473 field_comment : /^\s*(?:#|-{2}).*\n/
 474     {
 475         my $comment =  $item[1];
 476         $comment    =~ s/^\s*(#|--)\s*//;
 477         $comment    =~ s/\s*$//;
 478         $return     = $comment;
 479     }
 480
 481
 482 field_comment2 : /comment/i /'.*?'/
 483     {
 484         my $comment = $item[2];
 485         $comment    =~ s/^'//;
 486         $comment    =~ s/'$//;
 487         $return     = $comment;
 488     }
 489
 490 blank : /\s*/
 491
 492 field : field_comment(s?) field_name data_type field_qualifier(s?) field_comment2(?) reference_definition(?) on_update(?) field_comment(s?)
 493     {
 494         my %qualifiers  = map { %$_ } @{ $item{'field_qualifier(s?)'} || [] };
 495         if ( my @type_quals = @{ $item{'data_type'}{'qualifiers'} || [] } ) {
 496             $qualifiers{ $_ } = 1 for @type_quals;
 497         }
 498
 499         my $null = defined $qualifiers{'not_null'}
 500                    ? $qualifiers{'not_null'} : 1;
 501         delete $qualifiers{'not_null'};
 502
 503         my @comments = ( @{ $item[1] }, @{ $item[5] }, @{ $item[8] } );
 504
 505         $return = {
 506             supertype   => 'field',
 507             name        => $item{'field_name'},
 508             data_type   => $item{'data_type'}{'type'},
 509             size        => $item{'data_type'}{'size'},
 510             list        => $item{'data_type'}{'list'},
 511             null        => $null,
 512             constraints => $item{'reference_definition(?)'},
 513             comments    => [ @comments ],
 514             %qualifiers,
 515         }
 516     }
 517     | <error>
 518
 519 field_qualifier : not_null
 520     {
 521         $return = {
 522              null => $item{'not_null'},
 523         }
 524     }
 525
 526 field_qualifier : default_val
 527     {
 528         $return = {
 529              default => $item{'default_val'},
 530         }
 531     }
 532
 533 field_qualifier : auto_inc
 534     {
 535         $return = {
 536              is_auto_inc => $item{'auto_inc'},
 537         }
 538     }
 539
 540 field_qualifier : primary_key
 541     {
 542         $return = {
 543              is_primary_key => $item{'primary_key'},
 544         }
 545     }
 546
 547 field_qualifier : unsigned
 548     {
 549         $return = {
 550              is_unsigned => $item{'unsigned'},
 551         }
 552     }
 553
 554 field_qualifier : /character set/i WORD
 555     {
 556         $return = {
 557             'CHARACTER SET' => $item[2],
 558         }
 559     }
 560
 561 field_qualifier : /collate/i WORD
 562     {
 563         $return = {
 564             COLLATE => $item[2],
 565         }
 566     }
 567
 568 field_qualifier : /on update/i CURRENT_TIMESTAMP
 569     {
 570         $return = {
 571             'ON UPDATE' => $item[2],
 572         }
 573     }
 574
 575 field_qualifier : /unique/i KEY(?)
 576     {
 577         $return = {
 578             is_unique => 1,
 579         }
 580     }
 581
 582 field_qualifier : KEY
 583     {
 584         $return = {
 585             has_index => 1,
 586         }
 587     }
 588
 589 reference_definition : /references/i table_name parens_field_list(?) match_type(?) on_delete(?) on_update(?)
 590     {
 591         $return = {
 592             type             => 'foreign_key',
 593             reference_table  => $item[2],
 594             reference_fields => $item[3][0],
 595             match_type       => $item[4][0],
 596             on_delete        => $item[5][0],
 597             on_update        => $item[6][0],
 598         }
 599     }
 600
 601 match_type : /match full/i { 'full' }
 602     |
 603     /match partial/i { 'partial' }
 604
 605 on_delete : /on delete/i reference_option
 606     { $item[2] }
 607
 608 on_update :
 609     /on update/i CURRENT_TIMESTAMP
 610     { $item[2] }
 611     |
 612     /on update/i reference_option
 613     { $item[2] }
 614
 615 reference_option: /restrict/i |
 616     /cascade/i   |
 617     /set null/i  |
 618     /no action/i |
 619     /set default/i
 620     { $item[1] }
 621
 622 index : normal_index
 623     | fulltext_index
 624     | spatial_index
 625     | <error>
 626
 627 table_name   : NAME
 628
 629 field_name   : NAME
 630
 631 index_name   : NAME
 632
 633 data_type    : WORD parens_value_list(s?) type_qualifier(s?)
 634     {
 635         my $type = $item[1];
 636         my $size; # field size, applicable only to non-set fields
 637         my $list; # set list, applicable only to sets (duh)
 638
 639         if ( uc($type) =~ /^(SET|ENUM)$/ ) {
 640             $size = undef;
 641             $list = $item[2][0];
 642         }
 643         else {
 644             $size = $item[2][0];
 645             $list = [];
 646         }
 647
 648
 649         $return        = {
 650             type       => $type,
 651             size       => $size,
 652             list       => $list,
 653             qualifiers => $item[3],
 654         }
 655     }
 656
 657 parens_field_list : '(' field_name(s /,/) ')'
 658     { $item[2] }
 659
 660 parens_value_list : '(' VALUE(s /,/) ')'
 661     { $item[2] }
 662
 663 type_qualifier : /(BINARY|UNSIGNED|ZEROFILL)/i
 664     { lc $item[1] }
 665
 666 field_type   : WORD
 667
 668 create_index : /create/i /index/i
 669
 670 not_null     : /not/i /null/i
 671     { $return = 0 }
 672     |
 673     /null/i
 674     { $return = 1 }
 675
 676 unsigned     : /unsigned/i { $return = 0 }
 677
 678 default_val :
 679     /default/i CURRENT_TIMESTAMP
 680     {
 681         $return =  $item[2];
 682     }
 683     |
 684     /default/i string
 685     {
 686         $item[2] =~ s/^\s*'|'\s*$//g or $item[2] =~ s/^\s*"|"\s*$//g;
 687         $return  =  $item[2];
 688     }
 689     |
 690     /default/i bit
 691     {
 692         $item[2] =~ s/b['"]([01]+)['"]/$1/g;
 693         $return  =  $item[2];
 694     }
 695     |
 696     /default/i /[\w\d:.-]+/
 697     {
 698         $return  =  $item[2];
 699     }
 700
 701 auto_inc : /auto_increment/i { 1 }
 702
 703 primary_key : /primary/i /key/i { 1 }
 704
 705 constraint : primary_key_def
 706     | unique_key_def
 707     | foreign_key_def
 708     | <error>
 709
 710 foreign_key_def : foreign_key_def_begin parens_field_list reference_definition
 711     {
 712         $return              =  {
 713             supertype        => 'constraint',
 714             type             => 'foreign_key',
 715             name             => $item[1],
 716             fields           => $item[2],
 717             %{ $item{'reference_definition'} },
 718         }
 719     }
 720
 721 foreign_key_def_begin : /constraint/i /foreign key/i WORD
 722     { $return = $item[3] }
 723     |
 724     /constraint/i NAME /foreign key/i
 725     { $return = $item[2] }
 726     |
 727     /constraint/i /foreign key/i
 728     { $return = '' }
 729     |
 730     /foreign key/i WORD
 731     { $return = $item[2] }
 732     |
 733     /foreign key/i
 734     { $return = '' }
 735
 736 primary_key_def : primary_key index_type(?) '(' name_with_opt_paren(s /,/) ')' index_type(?)
 737     {
 738         $return       = {
 739             supertype => 'constraint',
 740             type      => 'primary_key',
 741             fields    => $item[4],
 742             options   => $item[2][0] || $item[6][0],
 743         };
 744     }
 745     # In theory, and according to the doc, names should not be allowed here, but
 746     # MySQL accept (and ignores) them, so we are not going to be less :)
 747     | primary_key index_name_not_using(?) '(' name_with_opt_paren(s /,/) ')' index_type(?)
 748     {
 749         $return       = {
 750             supertype => 'constraint',
 751             type      => 'primary_key',
 752             fields    => $item[4],
 753             options   => $item[6][0],
 754         };
 755     }
 756
 757 unique_key_def : UNIQUE KEY(?) index_name_not_using(?) index_type(?) '(' name_with_opt_paren(s /,/) ')' index_type(?)
 758     {
 759         $return       = {
 760             supertype => 'constraint',
 761             name      => $item[3][0],
 762             type      => 'unique',
 763             fields    => $item[6],
 764             options   => $item[4][0] || $item[8][0],
 765         }
 766     }
 767
 768 normal_index : KEY index_name_not_using(?) index_type(?) '(' name_with_opt_paren(s /,/) ')' index_type(?)
 769     {
 770         $return       = {
 771             supertype => 'index',
 772             type      => 'normal',
 773             name      => $item[2][0],
 774             fields    => $item[5],
 775             options   => $item[3][0] || $item[7][0],
 776         }
 777     }
 778
 779 index_name_not_using : QUOTED_NAME
 780     | /(\b(?!using)\w+\b)/ { $return = ($1 =~ /^using/i) ? undef : $1 }
 781
 782 index_type : /using (btree|hash|rtree)/i { $return = uc $1 }
 783
 784 fulltext_index : /fulltext/i KEY(?) index_name(?) '(' name_with_opt_paren(s /,/) ')'
 785     {
 786         $return       = {
 787             supertype => 'index',
 788             type      => 'fulltext',
 789             name      => $item{'index_name(?)'}[0],
 790             fields    => $item[5],
 791         }
 792     }
 793
 794 spatial_index : /spatial/i KEY(?) index_name(?) '(' name_with_opt_paren(s /,/) ')'
 795     {
 796         $return       = {
 797             supertype => 'index',
 798             type      => 'spatial',
 799             name      => $item{'index_name(?)'}[0],
 800             fields    => $item[5],
 801         }
 802     }
 803
 804 name_with_opt_paren : NAME parens_value_list(s?)
 805     { $item[2][0] ? "$item[1]($item[2][0][0])" : $item[1] }
 806
 807 UNIQUE : /unique/i
 808
 809 KEY : /key/i | /index/i
 810
 811 table_option : /comment/i /=/ /'.*?'/
 812     {
 813         my $comment = $item[3];
 814         $comment    =~ s/^'//;
 815         $comment    =~ s/'$//;
 816         $return     = { comment => $comment };
 817     }
 818     | /(default )?(charset|character set)/i /\s*=?\s*/ WORD
 819     {
 820         $return = { 'CHARACTER SET' => $item[3] };
 821     }
 822     | /collate/i WORD
 823     {
 824         $return = { 'COLLATE' => $item[2] }
 825     }
 826     | /union/i /\s*=\s*/ '(' table_name(s /,/) ')'
 827     {
 828         $return = { $item[1] => $item[4] };
 829     }
 830     | WORD /\s*=\s*/ MAYBE_QUOTED_WORD
 831     {
 832         $return = { $item[1] => $item[3] };
 833     }
 834
 835 MAYBE_QUOTED_WORD: /\w+/
 836                  | /'(\w+)'/
 837                  { $return = $1 }
 838                  | /"(\w+)"/
 839                  { $return = $1 }
 840
 841 default : /default/i
 842
 843 ADD : /add/i
 844
 845 ALTER : /alter/i
 846
 847 CREATE : /create/i
 848
 849 TEMPORARY : /temporary/i
 850
 851 TABLE : /table/i
 852
 853 WORD : /\w+/
 854
 855 DIGITS : /\d+/
 856
 857 COMMA : ','
 858
 859 BACKTICK : '`'
 860
 861 DOUBLE_QUOTE: '"'
 862
 863 SINGLE_QUOTE: "'"
 864
 865 QUOTED_NAME : BACKTICK /[^`]+/ BACKTICK
 866     { $item[2] }
 867     | DOUBLE_QUOTE /[^"]+/ DOUBLE_QUOTE
 868     { $item[2] }
 869     | SINGLE_QUOTE /[^']+/ SINGLE_QUOTE
 870     { $item[2] }
 871
 872 NAME: QUOTED_NAME
 873     | /\w+/
 874
 875 VALUE : /[-+]?\.?\d+(?:[eE]\d+)?/
 876     { $item[1] }
 877     | QUOTED_NAME
 878     {
 879         # remove leading/trailing quotes
 880         my $val = $item[1];
 881         $val    =~ s/^['"]|['"]$//g;
 882         $return = $val;
 883     }
 884     | /NULL/
 885     { 'NULL' }
 886
 887 # always a scalar-ref, so that it is treated as a function and not quoted by consumers
 888 CURRENT_TIMESTAMP :
 889       /current_timestamp(\(\))?/i { \'CURRENT_TIMESTAMP' }
 890     | /now\(\)/i { \'CURRENT_TIMESTAMP' }
 891
 892 END_OF_GRAMMAR
 893
 894 sub parse {
 895     my ( $translator, $data ) = @_;
 896
 897     # Enable warnings within the Parse::RecDescent module.
 898     # Make sure the parser dies when it encounters an error
 899     local $::RD_ERRORS = 1 unless defined $::RD_ERRORS;
 900     # Enable warnings. This will warn on unused rules &c.
 901     local $::RD_WARN   = 1 unless defined $::RD_WARN;
 902     # Give out hints to help fix problems.
 903     local $::RD_HINT   = 1 unless defined $::RD_HINT;
 904     local $::RD_TRACE  = $translator->trace ? 1 : undef;
 905     local $DEBUG       = $translator->debug;
 906
 907     my $parser = ddl_parser_instance('MySQL');
 908
 909     # Preprocess for MySQL-specific and not-before-version comments
 910     # from mysqldump
 911     my $parser_version = parse_mysql_version(
 912         $translator->parser_args->{mysql_parser_version}, 'mysql'
 913     ) || DEFAULT_PARSER_VERSION;
 914
 915     while ( $data =~
 916         s#/\*!(\d{5})?(.*?)\*/#($1 && $1 > $parser_version ? '' : $2)#es
 917     ) {
 918         # do nothing; is there a better way to write this? -- ky
 919     }
 920
 921     my $result = $parser->startrule($data);
 922     return $translator->error( "Parse failed." ) unless defined $result;
 923     warn "Parse result:".Dumper( $result ) if $DEBUG;
 924
 925     my $schema = $translator->schema;
 926     $schema->name($result->{'database_name'}) if $result->{'database_name'};
 927
 928     my @tables = sort {
 929         $result->{'tables'}{ $a }{'order'}
 930         <=>
 931         $result->{'tables'}{ $b }{'order'}
 932     } keys %{ $result->{'tables'} };
 933
 934     for my $table_name ( @tables ) {
 935         my $tdata =  $result->{tables}{ $table_name };
 936         my $table =  $schema->add_table(
 937             name  => $tdata->{'table_name'},
 938         ) or die $schema->error;
 939
 940         $table->comments( $tdata->{'comments'} );
 941
 942         my @fields = sort {
 943             $tdata->{'fields'}->{$a}->{'order'}
 944             <=>
 945             $tdata->{'fields'}->{$b}->{'order'}
 946         } keys %{ $tdata->{'fields'} };
 947
 948         for my $fname ( @fields ) {
 949             my $fdata = $tdata->{'fields'}{ $fname };
 950             my $field = $table->add_field(
 951                 name              => $fdata->{'name'},
 952                 data_type         => $fdata->{'data_type'},
 953                 size              => $fdata->{'size'},
 954                 default_value     => $fdata->{'default'},
 955                 is_auto_increment => $fdata->{'is_auto_inc'},
 956                 is_nullable       => $fdata->{'null'},
 957                 comments          => $fdata->{'comments'},
 958             ) or die $table->error;
 959
 960             $table->primary_key( $field->name ) if $fdata->{'is_primary_key'};
 961
 962             for my $qual ( qw[ binary unsigned zerofill list collate ],
 963                     'character set', 'on update' ) {
 964                 if ( my $val = $fdata->{ $qual } || $fdata->{ uc $qual } ) {
 965                     next if ref $val eq 'ARRAY' && !@$val;
 966                     $field->extra( $qual, $val );
 967                 }
 968             }
 969
 970             if ( $fdata->{'has_index'} ) {
 971                 $table->add_index(
 972                     name   => '',
 973                     type   => 'NORMAL',
 974                     fields => $fdata->{'name'},
 975                 ) or die $table->error;
 976             }
 977
 978             if ( $fdata->{'is_unique'} ) {
 979                 $table->add_constraint(
 980                     name   => '',
 981                     type   => 'UNIQUE',
 982                     fields => $fdata->{'name'},
 983                 ) or die $table->error;
 984             }
 985
 986             for my $cdata ( @{ $fdata->{'constraints'} } ) {
 987                 next unless $cdata->{'type'} eq 'foreign_key';
 988                 $cdata->{'fields'} ||= [ $field->name ];
 989                 push @{ $tdata->{'constraints'} }, $cdata;
 990             }
 991
 992         }
 993
 994         for my $idata ( @{ $tdata->{'indices'} || [] } ) {
 995             my $index  =  $table->add_index(
 996                 name   => $idata->{'name'},
 997                 type   => uc $idata->{'type'},
 998                 fields => $idata->{'fields'},
 999             ) or die $table->error;
1000         }
1001
1002         if ( my @options = @{ $tdata->{'table_options'} || [] } ) {
1003             my @cleaned_options;
1004             my @ignore_opts = $translator->parser_args->{'ignore_opts'}
1005                 ? split( /,/, $translator->parser_args->{'ignore_opts'} )
1006                 : ();
1007             if (@ignore_opts) {
1008                 my $ignores = { map { $_ => 1 } @ignore_opts };
1009                 foreach my $option (@options) {
1010                     # make sure the option isn't in ignore list
1011                     my ($option_key) = keys %$option;
1012                     if ( !exists $ignores->{$option_key} ) {
1013                         push @cleaned_options, $option;
1014                     }
1015                 }
1016             } else {
1017                 @cleaned_options = @options;
1018             }
1019             $table->options( \@cleaned_options ) or die $table->error;
1020         }
1021
1022         for my $cdata ( @{ $tdata->{'constraints'} || [] } ) {
1023             my $constraint       =  $table->add_constraint(
1024                 name             => $cdata->{'name'},
1025                 type             => $cdata->{'type'},
1026                 fields           => $cdata->{'fields'},
1027                 reference_table  => $cdata->{'reference_table'},
1028                 reference_fields => $cdata->{'reference_fields'},
1029                 match_type       => $cdata->{'match_type'} || '',
1030                 on_delete        => $cdata->{'on_delete'}
1031                                  || $cdata->{'on_delete_do'},
1032                 on_update        => $cdata->{'on_update'}
1033                                  || $cdata->{'on_update_do'},
1034             ) or die $table->error;
1035         }
1036
1037         # After the constrains and PK/idxs have been created,
1038         # we normalize fields
1039         normalize_field($_) for $table->get_fields;
1040     }
1041
1042     my @procedures = sort {
1043         $result->{procedures}->{ $a }->{'order'}
1044         <=>
1045         $result->{procedures}->{ $b }->{'order'}
1046     } keys %{ $result->{procedures} };
1047
1048     for my $proc_name ( @procedures ) {
1049         $schema->add_procedure(
1050             name  => $proc_name,
1051             owner => $result->{procedures}->{$proc_name}->{owner},
1052             sql   => $result->{procedures}->{$proc_name}->{sql},
1053         );
1054     }
1055
1056     my @views = sort {
1057         $result->{views}->{ $a }->{'order'}
1058         <=>
1059         $result->{views}->{ $b }->{'order'}
1060     } keys %{ $result->{views} };
1061
1062     for my $view_name ( @views ) {
1063         my $view = $result->{'views'}{ $view_name };
1064         my @flds = map { $_->{'alias'} || $_->{'name'} }
1065                    @{ $view->{'select'}{'columns'} || [] };
1066         my @from = map { $_->{'alias'} || $_->{'name'} }
1067                    @{ $view->{'from'}{'tables'} || [] };
1068
1069         $schema->add_view(
1070             name    => $view_name,
1071             sql     => $view->{'sql'},
1072             order   => $view->{'order'},
1073             fields  => \@flds,
1074             tables  => \@from,
1075             options => $view->{'options'}
1076         );
1077     }
1078
1079     return 1;
1080 }
1081
1082 # Takes a field, and returns
1083 sub normalize_field {
1084     my ($field) = @_;
1085     my ($size, $type, $list, $unsigned, $changed);
1086
1087     $size = $field->size;
1088     $type = $field->data_type;
1089     $list = $field->extra->{list} || [];
1090     $unsigned = defined($field->extra->{unsigned});
1091
1092     if ( !ref $size && $size eq 0 ) {
1093         if ( lc $type eq 'tinyint' ) {
1094             $changed = $size != 4 - $unsigned;
1095             $size = 4 - $unsigned;
1096         }
1097         elsif ( lc $type eq 'smallint' ) {
1098             $changed = $size != 6 - $unsigned;
1099             $size = 6 - $unsigned;
1100         }
1101         elsif ( lc $type eq 'mediumint' ) {
1102             $changed = $size != 9 - $unsigned;
1103             $size = 9 - $unsigned;
1104         }
1105         elsif ( $type =~ /^int(eger)?$/i ) {
1106             $changed = $size != 11 - $unsigned || $type ne 'int';
1107             $type = 'int';
1108             $size = 11 - $unsigned;
1109         }
1110         elsif ( lc $type eq 'bigint' ) {
1111             $changed = $size != 20;
1112             $size = 20;
1113         }
1114         elsif ( lc $type =~ /(float|double|decimal|numeric|real|fixed|dec)/ ) {
1115             my $old_size = (ref $size || '') eq 'ARRAY' ? $size : [];
1116             $changed     = @$old_size != 2
1117                         || $old_size->[0] != 8
1118                         || $old_size->[1] != 2;
1119             $size        = [8,2];
1120         }
1121     }
1122
1123     if ( $type =~ /^tiny(text|blob)$/i ) {
1124         $changed = $size != 255;
1125         $size = 255;
1126     }
1127     elsif ( $type =~ /^(blob|text)$/i ) {
1128         $changed = $size != 65_535;
1129         $size = 65_535;
1130     }
1131     elsif ( $type =~ /^medium(blob|text)$/i ) {
1132         $changed = $size != 16_777_215;
1133         $size = 16_777_215;
1134     }
1135     elsif ( $type =~ /^long(blob|text)$/i ) {
1136         $changed = $size != 4_294_967_295;
1137         $size = 4_294_967_295;
1138     }
1139
1140     if ( $field->data_type =~ /(set|enum)/i && !$field->size ) {
1141         my %extra = $field->extra;
1142         my $longest = 0;
1143         for my $len ( map { length } @{ $extra{'list'} || [] } ) {
1144             $longest = $len if $len > $longest;
1145         }
1146         $changed = 1;
1147         $size = $longest if $longest;
1148     }
1149
1150
1151     if ( $changed ) {
1152         # We only want to clone the field, not *everything*
1153         {
1154             local $field->{table} = undef;
1155             $field->parsed_field( dclone( $field ) );
1156             $field->parsed_field->{table} = $field->table;
1157         }
1158         $field->size( $size );
1159         $field->data_type( $type );
1160         $field->sql_data_type( $type_mapping{ lc $type } )
1161             if exists $type_mapping{ lc $type };
1162         $field->extra->{list} = $list if @$list;
1163     }
1164 }
1165
1166 1;
1167
1168 # -------------------------------------------------------------------
1169 # Where man is not nature is barren.
1170 # William Blake
1171 # -------------------------------------------------------------------
1172
1173 =pod
1174
1175 =head1 AUTHOR
1176
1177 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>,
1178 Chris Mungall E<lt>cjm@fruitfly.orgE<gt>.
1179
1180 =head1 SEE ALSO
1181
1182 Parse::RecDescent, SQL::Translator::Schema.
1183
1184 =cut