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.59';
 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)(s?)
 235
 236 insert : /insert/i  statement_body "$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 algorithm /view/i NAME not_delimiter "$delimiter"
 347     {
 348         @table_comments = ();
 349         my $view_name = $item[4];
 350         my $sql = "$item[1] $item[2] $item[3] $item[4] $item[5]";
 351
 352         # Hack to strip database from function calls in SQL
 353         $sql =~ s#`\w+`\.(`\w+`\()##g;
 354
 355         $views{ $view_name }{'order'}  = ++$view_order;
 356         $views{ $view_name }{'name'}   = $view_name;
 357         $views{ $view_name }{'sql'}    = $sql;
 358     }
 359
 360 algorithm : /algorithm/i /=/ WORD
 361     {
 362         $return = "$item[1]=$item[3]";
 363     }
 364
 365 not_delimiter : /.*?(?=$delimiter)/is
 366
 367 create_definition : constraint
 368     | index
 369     | field
 370     | comment
 371     | <error>
 372
 373 comment : /^\s*(?:#|-{2}).*\n/
 374     {
 375         my $comment =  $item[1];
 376         $comment    =~ s/^\s*(#|--)\s*//;
 377         $comment    =~ s/\s*$//;
 378         $return     = $comment;
 379     }
 380
 381 comment : /\/\*/ /.*?\*\//s
 382     {
 383         my $comment = $item[2];
 384         $comment = substr($comment, 0, -2);
 385         $comment    =~ s/^\s*|\s*$//g;
 386         $return = $comment;
 387     }
 388
 389 field_comment : /^\s*(?:#|-{2}).*\n/
 390     {
 391         my $comment =  $item[1];
 392         $comment    =~ s/^\s*(#|--)\s*//;
 393         $comment    =~ s/\s*$//;
 394         $return     = $comment;
 395     }
 396
 397
 398 field_comment2 : /comment/i /'.*?'/
 399     {
 400         my $comment = $item[2];
 401         $comment    =~ s/^'//;
 402         $comment    =~ s/'$//;
 403         $return     = $comment;
 404     }
 405
 406 blank : /\s*/
 407
 408 field : field_comment(s?) field_name data_type field_qualifier(s?) field_comment2(?) reference_definition(?) on_update(?) field_comment(s?)
 409     {
 410         my %qualifiers  = map { %$_ } @{ $item{'field_qualifier(s?)'} || [] };
 411         if ( my @type_quals = @{ $item{'data_type'}{'qualifiers'} || [] } ) {
 412             $qualifiers{ $_ } = 1 for @type_quals;
 413         }
 414
 415         my $null = defined $qualifiers{'not_null'}
 416                    ? $qualifiers{'not_null'} : 1;
 417         delete $qualifiers{'not_null'};
 418
 419         my @comments = ( @{ $item[1] }, @{ $item[5] }, @{ $item[8] } );
 420
 421         $return = {
 422             supertype   => 'field',
 423             name        => $item{'field_name'},
 424             data_type   => $item{'data_type'}{'type'},
 425             size        => $item{'data_type'}{'size'},
 426             list        => $item{'data_type'}{'list'},
 427             null        => $null,
 428             constraints => $item{'reference_definition(?)'},
 429             comments    => [ @comments ],
 430             %qualifiers,
 431         }
 432     }
 433     | <error>
 434
 435 field_qualifier : not_null
 436     {
 437         $return = {
 438              null => $item{'not_null'},
 439         }
 440     }
 441
 442 field_qualifier : default_val
 443     {
 444         $return = {
 445              default => $item{'default_val'},
 446         }
 447     }
 448
 449 field_qualifier : auto_inc
 450     {
 451         $return = {
 452              is_auto_inc => $item{'auto_inc'},
 453         }
 454     }
 455
 456 field_qualifier : primary_key
 457     {
 458         $return = {
 459              is_primary_key => $item{'primary_key'},
 460         }
 461     }
 462
 463 field_qualifier : unsigned
 464     {
 465         $return = {
 466              is_unsigned => $item{'unsigned'},
 467         }
 468     }
 469
 470 field_qualifier : /character set/i WORD
 471     {
 472         $return = {
 473             'CHARACTER SET' => $item[2],
 474         }
 475     }
 476
 477 field_qualifier : /collate/i WORD
 478     {
 479         $return = {
 480             COLLATE => $item[2],
 481         }
 482     }
 483
 484 field_qualifier : /on update/i CURRENT_TIMESTAMP
 485     {
 486         $return = {
 487             'ON UPDATE' => $item[2],
 488         }
 489     }
 490
 491 field_qualifier : /unique/i KEY(?)
 492     {
 493         $return = {
 494             is_unique => 1,
 495         }
 496     }
 497
 498 field_qualifier : KEY
 499     {
 500         $return = {
 501             has_index => 1,
 502         }
 503     }
 504
 505 reference_definition : /references/i table_name parens_field_list(?) match_type(?) on_delete(?) on_update(?)
 506     {
 507         $return = {
 508             type             => 'foreign_key',
 509             reference_table  => $item[2],
 510             reference_fields => $item[3][0],
 511             match_type       => $item[4][0],
 512             on_delete        => $item[5][0],
 513             on_update        => $item[6][0],
 514         }
 515     }
 516
 517 match_type : /match full/i { 'full' }
 518     |
 519     /match partial/i { 'partial' }
 520
 521 on_delete : /on delete/i reference_option
 522     { $item[2] }
 523
 524 on_update :
 525     /on update/i 'CURRENT_TIMESTAMP'
 526     { $item[2] }
 527     |
 528     /on update/i reference_option
 529     { $item[2] }
 530
 531 reference_option: /restrict/i |
 532     /cascade/i   |
 533     /set null/i  |
 534     /no action/i |
 535     /set default/i
 536     { $item[1] }
 537
 538 index : normal_index
 539     | fulltext_index
 540     | spatial_index
 541     | <error>
 542
 543 table_name   : NAME
 544
 545 field_name   : NAME
 546
 547 index_name   : NAME
 548
 549 data_type    : WORD parens_value_list(s?) type_qualifier(s?)
 550     {
 551         my $type = $item[1];
 552         my $size; # field size, applicable only to non-set fields
 553         my $list; # set list, applicable only to sets (duh)
 554
 555         if ( uc($type) =~ /^(SET|ENUM)$/ ) {
 556             $size = undef;
 557             $list = $item[2][0];
 558         }
 559         else {
 560             $size = $item[2][0];
 561             $list = [];
 562         }
 563
 564
 565         $return        = {
 566             type       => $type,
 567             size       => $size,
 568             list       => $list,
 569             qualifiers => $item[3],
 570         }
 571     }
 572
 573 parens_field_list : '(' field_name(s /,/) ')'
 574     { $item[2] }
 575
 576 parens_value_list : '(' VALUE(s /,/) ')'
 577     { $item[2] }
 578
 579 type_qualifier : /(BINARY|UNSIGNED|ZEROFILL)/i
 580     { lc $item[1] }
 581
 582 field_type   : WORD
 583
 584 create_index : /create/i /index/i
 585
 586 not_null     : /not/i /null/i
 587     { $return = 0 }
 588     |
 589     /null/i
 590     { $return = 1 }
 591
 592 unsigned     : /unsigned/i { $return = 0 }
 593
 594 #default_val  : /default/i /(?:')?[\s\w\d:.-]*(?:')?/
 595 #    {
 596 #        $item[2] =~ s/'//g;
 597 #        $return  =  $item[2];
 598 #    }
 599
 600 default_val :
 601     /default/i 'CURRENT_TIMESTAMP'
 602     {
 603         $return =  \$item[2];
 604     }
 605     |
 606     /default/i /'(?:.*?\\')*.*?'|(?:')?[\w\d:.-]*(?:')?/
 607     {
 608         $item[2] =~ s/^\s*'|'\s*$//g;
 609         $return  =  $item[2];
 610     }
 611
 612 auto_inc : /auto_increment/i { 1 }
 613
 614 primary_key : /primary/i /key/i { 1 }
 615
 616 constraint : primary_key_def
 617     | unique_key_def
 618     | foreign_key_def
 619     | <error>
 620
 621 foreign_key_def : foreign_key_def_begin parens_field_list reference_definition
 622     {
 623         $return              =  {
 624             supertype        => 'constraint',
 625             type             => 'foreign_key',
 626             name             => $item[1],
 627             fields           => $item[2],
 628             %{ $item{'reference_definition'} },
 629         }
 630     }
 631
 632 foreign_key_def_begin : /constraint/i /foreign key/i WORD
 633     { $return = $item[3] }
 634     |
 635     /constraint/i NAME /foreign key/i
 636     { $return = $item[2] }
 637     |
 638     /constraint/i /foreign key/i
 639     { $return = '' }
 640     |
 641     /foreign key/i WORD
 642     { $return = $item[2] }
 643     |
 644     /foreign key/i
 645     { $return = '' }
 646
 647 primary_key_def : primary_key index_name(?) '(' name_with_opt_paren(s /,/) ')'
 648     {
 649         $return       = {
 650             supertype => 'constraint',
 651             name      => $item{'index_name(?)'}[0],
 652             type      => 'primary_key',
 653             fields    => $item[4],
 654         };
 655     }
 656
 657 unique_key_def : UNIQUE KEY(?) index_name(?) '(' name_with_opt_paren(s /,/) ')'
 658     {
 659         $return       = {
 660             supertype => 'constraint',
 661             name      => $item{'index_name(?)'}[0],
 662             type      => 'unique',
 663             fields    => $item[5],
 664         }
 665     }
 666
 667 normal_index : KEY index_name(?) '(' name_with_opt_paren(s /,/) ')'
 668     {
 669         $return       = {
 670             supertype => 'index',
 671             type      => 'normal',
 672             name      => $item{'index_name(?)'}[0],
 673             fields    => $item[4],
 674         }
 675     }
 676
 677 fulltext_index : /fulltext/i KEY(?) index_name(?) '(' name_with_opt_paren(s /,/) ')'
 678     {
 679         $return       = {
 680             supertype => 'index',
 681             type      => 'fulltext',
 682             name      => $item{'index_name(?)'}[0],
 683             fields    => $item[5],
 684         }
 685     }
 686
 687 spatial_index : /spatial/i KEY(?) index_name(?) '(' name_with_opt_paren(s /,/) ')'
 688     {
 689         $return       = {
 690             supertype => 'index',
 691             type      => 'spatial',
 692             name      => $item{'index_name(?)'}[0],
 693             fields    => $item[5],
 694         }
 695     }
 696
 697 name_with_opt_paren : NAME parens_value_list(s?)
 698     { $item[2][0] ? "$item[1]($item[2][0][0])" : $item[1] }
 699
 700 UNIQUE : /unique/i
 701
 702 KEY : /key/i | /index/i
 703
 704 table_option : /comment/i /=/ /'.*?'/
 705     {
 706         my $comment = $item[3];
 707         $comment    =~ s/^'//;
 708         $comment    =~ s/'$//;
 709         $return     = { comment => $comment };
 710     }
 711     | /(default )?(charset|character set)/i /\s*=?\s*/ WORD
 712     {
 713         $return = { 'CHARACTER SET' => $item[3] };
 714     }
 715     | /collate/i WORD
 716     {
 717         $return = { 'COLLATE' => $item[2] }
 718     }
 719     | /union/i /\s*=\s*/ '(' table_name(s /,/) ')'
 720     {
 721         $return = { $item[1] => $item[4] };
 722     }
 723     | WORD /\s*=\s*/ MAYBE_QUOTED_WORD
 724     {
 725         $return = { $item[1] => $item[3] };
 726     }
 727
 728 MAYBE_QUOTED_WORD: /\w+/
 729                  | /'(\w+)'/
 730                  { $return = $1 }
 731                  | /"(\w+)"/
 732                  { $return = $1 }
 733
 734 default : /default/i
 735
 736 ADD : /add/i
 737
 738 ALTER : /alter/i
 739
 740 CREATE : /create/i
 741
 742 TEMPORARY : /temporary/i
 743
 744 TABLE : /table/i
 745
 746 WORD : /\w+/
 747
 748 DIGITS : /\d+/
 749
 750 COMMA : ','
 751
 752 BACKTICK : '`'
 753
 754 DOUBLE_QUOTE: '"'
 755
 756 NAME    : BACKTICK /[^`]+/ BACKTICK
 757     { $item[2] }
 758     | DOUBLE_QUOTE /[^"]+/ DOUBLE_QUOTE
 759     { $item[2] }
 760     | /\w+/
 761     { $item[1] }
 762
 763 VALUE   : /[-+]?\.?\d+(?:[eE]\d+)?/
 764     { $item[1] }
 765     | /'.*?'/
 766     {
 767         # remove leading/trailing quotes
 768         my $val = $item[1];
 769         $val    =~ s/^['"]|['"]$//g;
 770         $return = $val;
 771     }
 772     | /NULL/
 773     { 'NULL' }
 774
 775 CURRENT_TIMESTAMP : /current_timestamp(\(\))?/i
 776     | /now\(\)/i
 777     { 'CURRENT_TIMESTAMP' }
 778
 779 END_OF_GRAMMAR
 780
 781 # -------------------------------------------------------------------
 782 sub parse {
 783     my ( $translator, $data ) = @_;
 784     my $parser = Parse::RecDescent->new($GRAMMAR);
 785     local $::RD_TRACE  = $translator->trace ? 1 : undef;
 786     local $DEBUG       = $translator->debug;
 787
 788     unless (defined $parser) {
 789         return $translator->error("Error instantiating Parse::RecDescent ".
 790             "instance: Bad grammer");
 791     }
 792
 793     # Preprocess for MySQL-specific and not-before-version comments
 794     # from mysqldump
 795     my $parser_version = parse_mysql_version(
 796         $translator->parser_args->{mysql_parser_version}, 'mysql'
 797     ) || DEFAULT_PARSER_VERSION;
 798
 799     while ( $data =~
 800         s#/\*!(\d{5})?(.*?)\*/#($1 && $1 > $parser_version ? '' : $2)#es
 801     ) {
 802         # do nothing; is there a better way to write this? -- ky
 803     }
 804
 805     my $result = $parser->startrule($data);
 806     return $translator->error( "Parse failed." ) unless defined $result;
 807     warn "Parse result:".Dumper( $result ) if $DEBUG;
 808
 809     my $schema = $translator->schema;
 810     $schema->name($result->{'database_name'}) if $result->{'database_name'};
 811
 812     my @tables = sort {
 813         $result->{'tables'}{ $a }{'order'}
 814         <=>
 815         $result->{'tables'}{ $b }{'order'}
 816     } keys %{ $result->{'tables'} };
 817
 818     for my $table_name ( @tables ) {
 819         my $tdata =  $result->{tables}{ $table_name };
 820         my $table =  $schema->add_table(
 821             name  => $tdata->{'table_name'},
 822         ) or die $schema->error;
 823
 824         $table->comments( $tdata->{'comments'} );
 825
 826         my @fields = sort {
 827             $tdata->{'fields'}->{$a}->{'order'}
 828             <=>
 829             $tdata->{'fields'}->{$b}->{'order'}
 830         } keys %{ $tdata->{'fields'} };
 831
 832         for my $fname ( @fields ) {
 833             my $fdata = $tdata->{'fields'}{ $fname };
 834             my $field = $table->add_field(
 835                 name              => $fdata->{'name'},
 836                 data_type         => $fdata->{'data_type'},
 837                 size              => $fdata->{'size'},
 838                 default_value     => $fdata->{'default'},
 839                 is_auto_increment => $fdata->{'is_auto_inc'},
 840                 is_nullable       => $fdata->{'null'},
 841                 comments          => $fdata->{'comments'},
 842             ) or die $table->error;
 843
 844             $table->primary_key( $field->name ) if $fdata->{'is_primary_key'};
 845
 846             for my $qual ( qw[ binary unsigned zerofill list collate ],
 847                     'character set', 'on update' ) {
 848                 if ( my $val = $fdata->{ $qual } || $fdata->{ uc $qual } ) {
 849                     next if ref $val eq 'ARRAY' && !@$val;
 850                     $field->extra( $qual, $val );
 851                 }
 852             }
 853
 854             if ( $fdata->{'has_index'} ) {
 855                 $table->add_index(
 856                     name   => '',
 857                     type   => 'NORMAL',
 858                     fields => $fdata->{'name'},
 859                 ) or die $table->error;
 860             }
 861
 862             if ( $fdata->{'is_unique'} ) {
 863                 $table->add_constraint(
 864                     name   => '',
 865                     type   => 'UNIQUE',
 866                     fields => $fdata->{'name'},
 867                 ) or die $table->error;
 868             }
 869
 870             for my $cdata ( @{ $fdata->{'constraints'} } ) {
 871                 next unless $cdata->{'type'} eq 'foreign_key';
 872                 $cdata->{'fields'} ||= [ $field->name ];
 873                 push @{ $tdata->{'constraints'} }, $cdata;
 874             }
 875
 876         }
 877
 878         for my $idata ( @{ $tdata->{'indices'} || [] } ) {
 879             my $index  =  $table->add_index(
 880                 name   => $idata->{'name'},
 881                 type   => uc $idata->{'type'},
 882                 fields => $idata->{'fields'},
 883             ) or die $table->error;
 884         }
 885
 886         if ( my @options = @{ $tdata->{'table_options'} || [] } ) {
 887             my @cleaned_options;
 888             my @ignore_opts = $translator->parser_args->{'ignore_opts'}
 889                 ? split( /,/, $translator->parser_args->{'ignore_opts'} )
 890                 : ();
 891             if (@ignore_opts) {
 892                 my $ignores = { map { $_ => 1 } @ignore_opts };
 893                 foreach my $option (@options) {
 894                     # make sure the option isn't in ignore list
 895                     my ($option_key) = keys %$option;
 896                     if ( !exists $ignores->{$option_key} ) {
 897                         push @cleaned_options, $option;
 898                     }
 899                 }
 900             } else {
 901                 @cleaned_options = @options;
 902             }
 903             $table->options( \@cleaned_options ) or die $table->error;
 904         }
 905
 906         for my $cdata ( @{ $tdata->{'constraints'} || [] } ) {
 907             my $constraint       =  $table->add_constraint(
 908                 name             => $cdata->{'name'},
 909                 type             => $cdata->{'type'},
 910                 fields           => $cdata->{'fields'},
 911                 reference_table  => $cdata->{'reference_table'},
 912                 reference_fields => $cdata->{'reference_fields'},
 913                 match_type       => $cdata->{'match_type'} || '',
 914                 on_delete        => $cdata->{'on_delete'}
 915                                  || $cdata->{'on_delete_do'},
 916                 on_update        => $cdata->{'on_update'}
 917                                  || $cdata->{'on_update_do'},
 918             ) or die $table->error;
 919         }
 920
 921         # After the constrains and PK/idxs have been created,
 922         # we normalize fields
 923         normalize_field($_) for $table->get_fields;
 924     }
 925
 926     my @procedures = sort {
 927         $result->{procedures}->{ $a }->{'order'}
 928         <=>
 929         $result->{procedures}->{ $b }->{'order'}
 930     } keys %{ $result->{procedures} };
 931
 932     for my $proc_name ( @procedures ) {
 933         $schema->add_procedure(
 934             name  => $proc_name,
 935             owner => $result->{procedures}->{$proc_name}->{owner},
 936             sql   => $result->{procedures}->{$proc_name}->{sql},
 937         );
 938     }
 939
 940     my @views = sort {
 941         $result->{views}->{ $a }->{'order'}
 942         <=>
 943         $result->{views}->{ $b }->{'order'}
 944     } keys %{ $result->{views} };
 945
 946     for my $view_name ( keys %{ $result->{'views'} } ) {
 947         $schema->add_view(
 948             name => $view_name,
 949             sql  => $result->{'views'}->{$view_name}->{sql},
 950         );
 951     }
 952
 953     return 1;
 954 }
 955
 956 # Takes a field, and returns
 957 sub normalize_field {
 958     my ($field) = @_;
 959     my ($size, $type, $list, $changed) = @_;
 960
 961     $size = $field->size;
 962     $type = $field->data_type;
 963     $list = $field->extra->{list} || [];
 964
 965     if ( !ref $size && $size eq 0 ) {
 966         if ( lc $type eq 'tinyint' ) {
 967             $changed = $size != 4;
 968             $size = 4;
 969         }
 970         elsif ( lc $type eq 'smallint' ) {
 971             $changed = $size != 6;
 972             $size = 6;
 973         }
 974         elsif ( lc $type eq 'mediumint' ) {
 975             $changed = $size != 9;
 976             $size = 9;
 977         }
 978         elsif ( $type =~ /^int(eger)?$/i ) {
 979             $changed = $size != 11 || $type ne 'int';
 980             $type = 'int';
 981             $size = 11;
 982         }
 983         elsif ( lc $type eq 'bigint' ) {
 984             $changed = $size != 20;
 985             $size = 20;
 986         }
 987         elsif ( lc $type =~ /(float|double|decimal|numeric|real|fixed|dec)/ ) {
 988             my $old_size = (ref $size || '') eq 'ARRAY' ? $size : [];
 989             $changed     = @$old_size != 2
 990                         || $old_size->[0] != 8
 991                         || $old_size->[1] != 2;
 992             $size        = [8,2];
 993         }
 994     }
 995
 996     if ( $type =~ /^tiny(text|blob)$/i ) {
 997         $changed = $size != 255;
 998         $size = 255;
 999     }
1000     elsif ( $type =~ /^(blob|text)$/i ) {
1001         $changed = $size != 65_535;
1002         $size = 65_535;
1003     }
1004     elsif ( $type =~ /^medium(blob|text)$/i ) {
1005         $changed = $size != 16_777_215;
1006         $size = 16_777_215;
1007     }
1008     elsif ( $type =~ /^long(blob|text)$/i ) {
1009         $changed = $size != 4_294_967_295;
1010         $size = 4_294_967_295;
1011     }
1012
1013     if ( $field->data_type =~ /(set|enum)/i && !$field->size ) {
1014         my %extra = $field->extra;
1015         my $longest = 0;
1016         for my $len ( map { length } @{ $extra{'list'} || [] } ) {
1017             $longest = $len if $len > $longest;
1018         }
1019         $changed = 1;
1020         $size = $longest if $longest;
1021     }
1022
1023
1024     if ( $changed ) {
1025         # We only want to clone the field, not *everything*
1026         {
1027             local $field->{table} = undef;
1028             $field->parsed_field( dclone( $field ) );
1029             $field->parsed_field->{table} = $field->table;
1030         }
1031         $field->size( $size );
1032         $field->data_type( $type );
1033         $field->sql_data_type( $type_mapping{ lc $type } )
1034             if exists $type_mapping{ lc $type };
1035         $field->extra->{list} = $list if @$list;
1036     }
1037 }
1038
1039 1;
1040
1041 # -------------------------------------------------------------------
1042 # Where man is not nature is barren.
1043 # William Blake
1044 # -------------------------------------------------------------------
1045
1046 =pod
1047
1048 =head1 AUTHOR
1049
1050 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>,
1051 Chris Mungall E<lt>cjm@fruitfly.orgE<gt>.
1052
1053 =head1 SEE ALSO
1054
1055 Parse::RecDescent, SQL::Translator::Schema.
1056
1057 =cut