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