lib/SQL/Translator/Parser/MySQL.pm

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