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