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