lib/SQL/Translator/Parser/MySQL.pm

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