lib/SQL/Translator/Parser/MySQL.pm

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