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 QUOTED_NAME : BACKTICK /[^`]+/ BACKTICK
 864     { $item[2] }
 865     | DOUBLE_QUOTE /[^"]+/ DOUBLE_QUOTE
 866     { $item[2] }
 867
 868 NAME: QUOTED_NAME
 869     | /\w+/
 870
 871 VALUE : /[-+]?\.?\d+(?:[eE]\d+)?/
 872     { $item[1] }
 873     | /'.*?'/
 874     {
 875         # remove leading/trailing quotes
 876         my $val = $item[1];
 877         $val    =~ s/^['"]|['"]$//g;
 878         $return = $val;
 879     }
 880     | /NULL/
 881     { 'NULL' }
 882
 883 # always a scalar-ref, so that it is treated as a function and not quoted by consumers
 884 CURRENT_TIMESTAMP :
 885       /current_timestamp(\(\))?/i { \'CURRENT_TIMESTAMP' }
 886     | /now\(\)/i { \'CURRENT_TIMESTAMP' }
 887
 888 END_OF_GRAMMAR
 889
 890 sub parse {
 891     my ( $translator, $data ) = @_;
 892
 893     # Enable warnings within the Parse::RecDescent module.
 894     # Make sure the parser dies when it encounters an error
 895     local $::RD_ERRORS = 1 unless defined $::RD_ERRORS;
 896     # Enable warnings. This will warn on unused rules &c.
 897     local $::RD_WARN   = 1 unless defined $::RD_WARN;
 898     # Give out hints to help fix problems.
 899     local $::RD_HINT   = 1 unless defined $::RD_HINT;
 900     local $::RD_TRACE  = $translator->trace ? 1 : undef;
 901     local $DEBUG       = $translator->debug;
 902
 903     my $parser = ddl_parser_instance('MySQL');
 904
 905     # Preprocess for MySQL-specific and not-before-version comments
 906     # from mysqldump
 907     my $parser_version = parse_mysql_version(
 908         $translator->parser_args->{mysql_parser_version}, 'mysql'
 909     ) || DEFAULT_PARSER_VERSION;
 910
 911     while ( $data =~
 912         s#/\*!(\d{5})?(.*?)\*/#($1 && $1 > $parser_version ? '' : $2)#es
 913     ) {
 914         # do nothing; is there a better way to write this? -- ky
 915     }
 916
 917     my $result = $parser->startrule($data);
 918     return $translator->error( "Parse failed." ) unless defined $result;
 919     warn "Parse result:".Dumper( $result ) if $DEBUG;
 920
 921     my $schema = $translator->schema;
 922     $schema->name($result->{'database_name'}) if $result->{'database_name'};
 923
 924     my @tables = sort {
 925         $result->{'tables'}{ $a }{'order'}
 926         <=>
 927         $result->{'tables'}{ $b }{'order'}
 928     } keys %{ $result->{'tables'} };
 929
 930     for my $table_name ( @tables ) {
 931         my $tdata =  $result->{tables}{ $table_name };
 932         my $table =  $schema->add_table(
 933             name  => $tdata->{'table_name'},
 934         ) or die $schema->error;
 935
 936         $table->comments( $tdata->{'comments'} );
 937
 938         my @fields = sort {
 939             $tdata->{'fields'}->{$a}->{'order'}
 940             <=>
 941             $tdata->{'fields'}->{$b}->{'order'}
 942         } keys %{ $tdata->{'fields'} };
 943
 944         for my $fname ( @fields ) {
 945             my $fdata = $tdata->{'fields'}{ $fname };
 946             my $field = $table->add_field(
 947                 name              => $fdata->{'name'},
 948                 data_type         => $fdata->{'data_type'},
 949                 size              => $fdata->{'size'},
 950                 default_value     => $fdata->{'default'},
 951                 is_auto_increment => $fdata->{'is_auto_inc'},
 952                 is_nullable       => $fdata->{'null'},
 953                 comments          => $fdata->{'comments'},
 954             ) or die $table->error;
 955
 956             $table->primary_key( $field->name ) if $fdata->{'is_primary_key'};
 957
 958             for my $qual ( qw[ binary unsigned zerofill list collate ],
 959                     'character set', 'on update' ) {
 960                 if ( my $val = $fdata->{ $qual } || $fdata->{ uc $qual } ) {
 961                     next if ref $val eq 'ARRAY' && !@$val;
 962                     $field->extra( $qual, $val );
 963                 }
 964             }
 965
 966             if ( $fdata->{'has_index'} ) {
 967                 $table->add_index(
 968                     name   => '',
 969                     type   => 'NORMAL',
 970                     fields => $fdata->{'name'},
 971                 ) or die $table->error;
 972             }
 973
 974             if ( $fdata->{'is_unique'} ) {
 975                 $table->add_constraint(
 976                     name   => '',
 977                     type   => 'UNIQUE',
 978                     fields => $fdata->{'name'},
 979                 ) or die $table->error;
 980             }
 981
 982             for my $cdata ( @{ $fdata->{'constraints'} } ) {
 983                 next unless $cdata->{'type'} eq 'foreign_key';
 984                 $cdata->{'fields'} ||= [ $field->name ];
 985                 push @{ $tdata->{'constraints'} }, $cdata;
 986             }
 987
 988         }
 989
 990         for my $idata ( @{ $tdata->{'indices'} || [] } ) {
 991             my $index  =  $table->add_index(
 992                 name   => $idata->{'name'},
 993                 type   => uc $idata->{'type'},
 994                 fields => $idata->{'fields'},
 995             ) or die $table->error;
 996         }
 997
 998         if ( my @options = @{ $tdata->{'table_options'} || [] } ) {
 999             my @cleaned_options;
1000             my @ignore_opts = $translator->parser_args->{'ignore_opts'}
1001                 ? split( /,/, $translator->parser_args->{'ignore_opts'} )
1002                 : ();
1003             if (@ignore_opts) {
1004                 my $ignores = { map { $_ => 1 } @ignore_opts };
1005                 foreach my $option (@options) {
1006                     # make sure the option isn't in ignore list
1007                     my ($option_key) = keys %$option;
1008                     if ( !exists $ignores->{$option_key} ) {
1009                         push @cleaned_options, $option;
1010                     }
1011                 }
1012             } else {
1013                 @cleaned_options = @options;
1014             }
1015             $table->options( \@cleaned_options ) or die $table->error;
1016         }
1017
1018         for my $cdata ( @{ $tdata->{'constraints'} || [] } ) {
1019             my $constraint       =  $table->add_constraint(
1020                 name             => $cdata->{'name'},
1021                 type             => $cdata->{'type'},
1022                 fields           => $cdata->{'fields'},
1023                 reference_table  => $cdata->{'reference_table'},
1024                 reference_fields => $cdata->{'reference_fields'},
1025                 match_type       => $cdata->{'match_type'} || '',
1026                 on_delete        => $cdata->{'on_delete'}
1027                                  || $cdata->{'on_delete_do'},
1028                 on_update        => $cdata->{'on_update'}
1029                                  || $cdata->{'on_update_do'},
1030             ) or die $table->error;
1031         }
1032
1033         # After the constrains and PK/idxs have been created,
1034         # we normalize fields
1035         normalize_field($_) for $table->get_fields;
1036     }
1037
1038     my @procedures = sort {
1039         $result->{procedures}->{ $a }->{'order'}
1040         <=>
1041         $result->{procedures}->{ $b }->{'order'}
1042     } keys %{ $result->{procedures} };
1043
1044     for my $proc_name ( @procedures ) {
1045         $schema->add_procedure(
1046             name  => $proc_name,
1047             owner => $result->{procedures}->{$proc_name}->{owner},
1048             sql   => $result->{procedures}->{$proc_name}->{sql},
1049         );
1050     }
1051
1052     my @views = sort {
1053         $result->{views}->{ $a }->{'order'}
1054         <=>
1055         $result->{views}->{ $b }->{'order'}
1056     } keys %{ $result->{views} };
1057
1058     for my $view_name ( @views ) {
1059         my $view = $result->{'views'}{ $view_name };
1060         my @flds = map { $_->{'alias'} || $_->{'name'} }
1061                    @{ $view->{'select'}{'columns'} || [] };
1062         my @from = map { $_->{'alias'} || $_->{'name'} }
1063                    @{ $view->{'from'}{'tables'} || [] };
1064
1065         $schema->add_view(
1066             name    => $view_name,
1067             sql     => $view->{'sql'},
1068             order   => $view->{'order'},
1069             fields  => \@flds,
1070             tables  => \@from,
1071             options => $view->{'options'}
1072         );
1073     }
1074
1075     return 1;
1076 }
1077
1078 # Takes a field, and returns
1079 sub normalize_field {
1080     my ($field) = @_;
1081     my ($size, $type, $list, $unsigned, $changed);
1082
1083     $size = $field->size;
1084     $type = $field->data_type;
1085     $list = $field->extra->{list} || [];
1086     $unsigned = defined($field->extra->{unsigned});
1087
1088     if ( !ref $size && $size eq 0 ) {
1089         if ( lc $type eq 'tinyint' ) {
1090             $changed = $size != 4 - $unsigned;
1091             $size = 4 - $unsigned;
1092         }
1093         elsif ( lc $type eq 'smallint' ) {
1094             $changed = $size != 6 - $unsigned;
1095             $size = 6 - $unsigned;
1096         }
1097         elsif ( lc $type eq 'mediumint' ) {
1098             $changed = $size != 9 - $unsigned;
1099             $size = 9 - $unsigned;
1100         }
1101         elsif ( $type =~ /^int(eger)?$/i ) {
1102             $changed = $size != 11 - $unsigned || $type ne 'int';
1103             $type = 'int';
1104             $size = 11 - $unsigned;
1105         }
1106         elsif ( lc $type eq 'bigint' ) {
1107             $changed = $size != 20;
1108             $size = 20;
1109         }
1110         elsif ( lc $type =~ /(float|double|decimal|numeric|real|fixed|dec)/ ) {
1111             my $old_size = (ref $size || '') eq 'ARRAY' ? $size : [];
1112             $changed     = @$old_size != 2
1113                         || $old_size->[0] != 8
1114                         || $old_size->[1] != 2;
1115             $size        = [8,2];
1116         }
1117     }
1118
1119     if ( $type =~ /^tiny(text|blob)$/i ) {
1120         $changed = $size != 255;
1121         $size = 255;
1122     }
1123     elsif ( $type =~ /^(blob|text)$/i ) {
1124         $changed = $size != 65_535;
1125         $size = 65_535;
1126     }
1127     elsif ( $type =~ /^medium(blob|text)$/i ) {
1128         $changed = $size != 16_777_215;
1129         $size = 16_777_215;
1130     }
1131     elsif ( $type =~ /^long(blob|text)$/i ) {
1132         $changed = $size != 4_294_967_295;
1133         $size = 4_294_967_295;
1134     }
1135
1136     if ( $field->data_type =~ /(set|enum)/i && !$field->size ) {
1137         my %extra = $field->extra;
1138         my $longest = 0;
1139         for my $len ( map { length } @{ $extra{'list'} || [] } ) {
1140             $longest = $len if $len > $longest;
1141         }
1142         $changed = 1;
1143         $size = $longest if $longest;
1144     }
1145
1146
1147     if ( $changed ) {
1148         # We only want to clone the field, not *everything*
1149         {
1150             local $field->{table} = undef;
1151             $field->parsed_field( dclone( $field ) );
1152             $field->parsed_field->{table} = $field->table;
1153         }
1154         $field->size( $size );
1155         $field->data_type( $type );
1156         $field->sql_data_type( $type_mapping{ lc $type } )
1157             if exists $type_mapping{ lc $type };
1158         $field->extra->{list} = $list if @$list;
1159     }
1160 }
1161
1162 1;
1163
1164 # -------------------------------------------------------------------
1165 # Where man is not nature is barren.
1166 # William Blake
1167 # -------------------------------------------------------------------
1168
1169 =pod
1170
1171 =head1 AUTHOR
1172
1173 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>,
1174 Chris Mungall E<lt>cjm@fruitfly.orgE<gt>.
1175
1176 =head1 SEE ALSO
1177
1178 Parse::RecDescent, SQL::Translator::Schema.
1179
1180 =cut