[dbsrgits/SQL-Translator.git] / lib / SQL / Translator / Parser / MySQL.pm

package SQL::Translator::Parser::MySQL;

# -------------------------------------------------------------------
# $Id: MySQL.pm,v 1.40 2003-09-08 18:16:04 kycl4rk Exp $
# -------------------------------------------------------------------
# Copyright (C) 2003 Ken Y. Clark <kclark@cpan.org>,
#                    darren chamberlain <darren@cpan.org>,
#                    Chris Mungall <cjm@fruitfly.org>
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License as
# published by the Free Software Foundation; version 2.
#
# This program is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
# 02111-1307  USA
# -------------------------------------------------------------------

=head1 NAME

SQL::Translator::Parser::MySQL - parser for MySQL

=head1 SYNOPSIS

  use SQL::Translator;
  use SQL::Translator::Parser::MySQL;

  my $translator = SQL::Translator->new;
  $translator->parser("SQL::Translator::Parser::MySQL");

=head1 DESCRIPTION

The grammar is influenced heavily by Tim Bunce's "mysql2ora" grammar.

Here's the word from the MySQL site
(http://www.mysql.com/doc/en/CREATE_TABLE.html):

  CREATE [TEMPORARY] TABLE [IF NOT EXISTS] tbl_name [(create_definition,...)]
  [table_options] [select_statement]
  
  or
  
  CREATE [TEMPORARY] TABLE [IF NOT EXISTS] tbl_name LIKE old_table_name;
  
  create_definition:
    col_name type [NOT NULL | NULL] [DEFAULT default_value] [AUTO_INCREMENT]
              [PRIMARY KEY] [reference_definition]
    or    PRIMARY KEY (index_col_name,...)
    or    KEY [index_name] (index_col_name,...)
    or    INDEX [index_name] (index_col_name,...)
    or    UNIQUE [INDEX] [index_name] (index_col_name,...)
    or    FULLTEXT [INDEX] [index_name] (index_col_name,...)
    or    [CONSTRAINT symbol] FOREIGN KEY [index_name] (index_col_name,...)
              [reference_definition]
    or    CHECK (expr)
  
  type:
          TINYINT[(length)] [UNSIGNED] [ZEROFILL]
    or    SMALLINT[(length)] [UNSIGNED] [ZEROFILL]
    or    MEDIUMINT[(length)] [UNSIGNED] [ZEROFILL]
    or    INT[(length)] [UNSIGNED] [ZEROFILL]
    or    INTEGER[(length)] [UNSIGNED] [ZEROFILL]
    or    BIGINT[(length)] [UNSIGNED] [ZEROFILL]
    or    REAL[(length,decimals)] [UNSIGNED] [ZEROFILL]
    or    DOUBLE[(length,decimals)] [UNSIGNED] [ZEROFILL]
    or    FLOAT[(length,decimals)] [UNSIGNED] [ZEROFILL]
    or    DECIMAL(length,decimals) [UNSIGNED] [ZEROFILL]
    or    NUMERIC(length,decimals) [UNSIGNED] [ZEROFILL]
    or    CHAR(length) [BINARY]
    or    VARCHAR(length) [BINARY]
    or    DATE
    or    TIME
    or    TIMESTAMP
    or    DATETIME
    or    TINYBLOB
    or    BLOB
    or    MEDIUMBLOB
    or    LONGBLOB
    or    TINYTEXT
    or    TEXT
    or    MEDIUMTEXT
    or    LONGTEXT
    or    ENUM(value1,value2,value3,...)
    or    SET(value1,value2,value3,...)
  
  index_col_name:
          col_name [(length)]
  
  reference_definition:
          REFERENCES tbl_name [(index_col_name,...)]
                     [MATCH FULL | MATCH PARTIAL]
                     [ON DELETE reference_option]
                     [ON UPDATE reference_option]
  
  reference_option:
          RESTRICT | CASCADE | SET NULL | NO ACTION | SET DEFAULT
  
  table_options:
          TYPE = {BDB | HEAP | ISAM | InnoDB | MERGE | MRG_MYISAM | MYISAM }
  or      AUTO_INCREMENT = #
  or      AVG_ROW_LENGTH = #
  or      CHECKSUM = {0 | 1}
  or      COMMENT = "string"
  or      MAX_ROWS = #
  or      MIN_ROWS = #
  or      PACK_KEYS = {0 | 1 | DEFAULT}
  or      PASSWORD = "string"
  or      DELAY_KEY_WRITE = {0 | 1}
  or      ROW_FORMAT= { default | dynamic | fixed | compressed }
  or      RAID_TYPE= {1 | STRIPED | RAID0 } RAID_CHUNKS=#  RAID_CHUNKSIZE=#
  or      UNION = (table_name,[table_name...])
  or      INSERT_METHOD= {NO | FIRST | LAST }
  or      DATA DIRECTORY="absolute path to directory"
  or      INDEX DIRECTORY="absolute path to directory"

=cut

use strict;
use vars qw[ $DEBUG $VERSION $GRAMMAR @EXPORT_OK ];
$VERSION = sprintf "%d.%02d", q$Revision: 1.40 $ =~ /(\d+)\.(\d+)/;
$DEBUG   = 0 unless defined $DEBUG;

use Data::Dumper;
use Parse::RecDescent;
use Exporter;
use base qw(Exporter);

@EXPORT_OK = qw(parse);

# Enable warnings within the Parse::RecDescent module.
$::RD_ERRORS = 1; # Make sure the parser dies when it encounters an error
$::RD_WARN   = 1; # Enable warnings. This will warn on unused rules &c.
$::RD_HINT   = 1; # Give out hints to help fix problems.

$GRAMMAR = q!

{ 
    my ( %tables, $table_order, @table_comments );
}

#
# The "eofile" rule makes the parser fail if any "statement" rule
# fails.  Otherwise, the first successful match by a "statement" 
# won't cause the failure needed to know that the parse, as a whole,
# failed. -ky
#
startrule : statement(s) eofile { \%tables }

eofile : /^\Z/

statement : comment
    | use
    | set
    | drop
    | create
    | <error>

use : /use/i WORD ';'
    { @table_comments = () }

set : /set/i /[^;]+/ ';'
    { @table_comments = () }

drop : /drop/i TABLE /[^;]+/ ';'

drop : /drop/i WORD(s) ';'
    { @table_comments = () }

create : CREATE /database/i WORD ';'
    { @table_comments = () }

create : CREATE TEMPORARY(?) TABLE opt_if_not_exists(?) table_name '(' create_definition(s /,/) ')' table_option(s?) ';'
    { 
        my $table_name                       = $item{'table_name'};
        $tables{ $table_name }{'order'}      = ++$table_order;
        $tables{ $table_name }{'table_name'} = $table_name;

        if ( @table_comments ) {
            $tables{ $table_name }{'comments'} = [ @table_comments ];
            @table_comments = ();
        }

        my $i = 1;
        for my $definition ( @{ $item[7] } ) {
            if ( $definition->{'supertype'} eq 'field' ) {
                my $field_name = $definition->{'name'};
                $tables{ $table_name }{'fields'}{ $field_name } = 
                    { %$definition, order => $i };
                $i++;
        
                if ( $definition->{'is_primary_key'} ) {
                    push @{ $tables{ $table_name }{'constraints'} },
                        {
                            type   => 'primary_key',
                            fields => [ $field_name ],
                        }
                    ;
                }
            }
            elsif ( $definition->{'supertype'} eq 'constraint' ) {
                push @{ $tables{ $table_name }{'constraints'} }, $definition;
            }
            elsif ( $definition->{'supertype'} eq 'index' ) {
                push @{ $tables{ $table_name }{'indices'} }, $definition;
            }
        }

        for my $opt ( @{ $item{'table_option(s?)'} } ) {
            if ( my ( $key, $val ) = each %$opt ) {
                $tables{ $table_name }{'table_options'}{ $key } = $val;
            }
        }

        1;
    }

opt_if_not_exists : /if not exists/i

create : CREATE UNIQUE(?) /(index|key)/i index_name /on/i table_name '(' field_name(s /,/) ')' ';'
    {
        @table_comments = ();
        push @{ $tables{ $item{'table_name'} }{'indices'} },
            {
                name   => $item[4],
                type   => $item[2] ? 'unique' : 'normal',
                fields => $item[8],
            }
        ;
    }

create_definition : constraint 
    | index
    | field
    | <error>

comment : /^\s*(?:#|-{2}).*\n/ 
    { 
        my $comment =  $item[1];
        $comment    =~ s/^\s*(#|-{2})\s*//;
        $comment    =~ s/\s*$//;
        $return     = $comment;
        push @table_comments, $comment;
    }

field_comment : /^\s*(?:#|-{2}).*\n/ 
    { 
        my $comment =  $item[1];
        $comment    =~ s/^\s*(#|-{2})\s*//;
        $comment    =~ s/\s*$//;
        $return     = $comment;
    }

blank : /\s*/

field : field_comment(s?) field_name data_type field_qualifier(s?) reference_definition(?) field_comment(s?)
    { 
        my %qualifiers  = map { %$_ } @{ $item{'field_qualifier(s?)'} || [] };
        if ( my @type_quals = @{ $item{'data_type'}{'qualifiers'} || [] } ) {
            $qualifiers{ $_ } = 1 for @type_quals;
        }

        my $null = defined $qualifiers{'not_null'} 
                   ? $qualifiers{'not_null'} : 1;
        delete $qualifiers{'not_null'};

        my @comments = ( @{ $item[1] }, @{ $item[6] } );

        $return = { 
            supertype   => 'field',
            name        => $item{'field_name'}, 
            data_type   => $item{'data_type'}{'type'},
            size        => $item{'data_type'}{'size'},
            list        => $item{'data_type'}{'list'},
            null        => $null,
            constraints => $item{'reference_definition(?)'},
            comments    => [ @comments ],
            %qualifiers,
        } 
    }
    | <error>

field_qualifier : not_null
    { 
        $return = { 
             null => $item{'not_null'},
        } 
    }

field_qualifier : default_val
    { 
        $return = { 
             default => $item{'default_val'},
        } 
    }

field_qualifier : auto_inc
    { 
        $return = { 
             is_auto_inc => $item{'auto_inc'},
        } 
    }

field_qualifier : primary_key
    { 
        $return = { 
             is_primary_key => $item{'primary_key'},
        } 
    }

field_qualifier : unsigned
    { 
        $return = { 
             is_unsigned => $item{'unsigned'},
        } 
    }

field_qualifier : /character set/i WORD
    {
        $return = {
            character_set => $item[2],
        }
    }

reference_definition : /references/i table_name parens_field_list(?) match_type(?) on_delete_do(?) on_update_do(?)
    {
        $return = {
            type             => 'foreign_key',
            reference_table  => $item[2],
            reference_fields => $item[3][0],
            match_type       => $item[4][0],
            on_delete_do     => $item[5][0],
            on_update_do     => $item[6][0],
        }
    }

match_type : /match full/i { 'match_full' }
    |
    /match partial/i { 'match_partial' }

on_delete_do : /on delete/i reference_option
    { $item[2] }

on_update_do : /on update/i reference_option
    { $item[2] }

reference_option: /restrict/i | 
    /cascade/i   | 
    /set null/i  | 
    /no action/i | 
    /set default/i
    { $item[1] }  

index : normal_index
    | fulltext_index
    | <error>

table_name   : NAME

field_name   : NAME

index_name   : WORD

data_type    : WORD parens_value_list(s?) type_qualifier(s?)
    { 
        my $type = $item[1];
        my $size; # field size, applicable only to non-set fields
        my $list; # set list, applicable only to sets (duh)

        if ( uc($type) =~ /^(SET|ENUM)$/ ) {
            $size = undef;
            $list = $item[2][0];
        }
        else {
            $size = $item[2][0];
            $list = [];
        }

        unless ( @{ $size || [] } ) {
            if ( lc $type eq 'tinyint' ) {
                $size = 4;
            }
            elsif ( lc $type eq 'smallint' ) {
                $size = 6;
            }
            elsif ( lc $type eq 'mediumint' ) {
                $size = 9;
            }
            elsif ( $type =~ /^int(eger)?$/ ) {
                $type = 'int';
                $size = 11;
            }
            elsif ( lc $type eq 'bigint' ) {
                $size = 20;
            }
            elsif ( 
                lc $type =~ /(float|double|decimal|numeric|real|fixed|dec)/ 
            ) {
                $size = [8,2];
            }
        }

        if ( $type =~ /^tiny(text|blob)$/i ) {
            $size = 255;
        }
        elsif ( $type =~ /^(blob|text)$/i ) {
            $size = 65_535;
        }
        elsif ( $type =~ /^medium(blob|text)$/i ) {
            $size = 16_777_215;
        }
        elsif ( $type =~ /^long(blob|text)$/i ) {
            $size = 4_294_967_295;
        }

        $return        = { 
            type       => $type,
            size       => $size,
            list       => $list,
            qualifiers => $item[3],
        } 
    }

parens_field_list : '(' field_name(s /,/) ')'
    { $item[2] }

parens_value_list : '(' VALUE(s /,/) ')'
    { $item[2] }

type_qualifier : /(BINARY|UNSIGNED|ZEROFILL)/i
    { lc $item[1] }

field_type   : WORD

create_index : /create/i /index/i

not_null     : /not/i /null/i { $return = 0 }

unsigned     : /unsigned/i { $return = 0 }

default_val  : /default/i /(?:')?[\s\w\d:.-]*(?:')?/ 
    { 
        $item[2] =~ s/'//g; 
        $return  =  $item[2];
    }

auto_inc : /auto_increment/i { 1 }

primary_key : /primary/i /key/i { 1 }

constraint : primary_key_def
    | unique_key_def
    | foreign_key_def
    | <error>

foreign_key_def : opt_constraint(?) /foreign key/i parens_field_list reference_definition
    {
        $return              =  {
            supertype        => 'constraint',
            type             => 'foreign_key',
            name             => $item[1][0],
            fields           => $item[3],
            %{ $item{'reference_definition'} },
        }
    }

opt_constraint : /constraint/i NAME
    { $item[2] }

primary_key_def : primary_key index_name(?) '(' name_with_opt_paren(s /,/) ')'
    { 
        $return       = { 
            supertype => 'constraint',
            name      => $item{'index_name(?)'}[0],
            type      => 'primary_key',
            fields    => $item[4],
        };
    }

unique_key_def : UNIQUE KEY(?) index_name(?) '(' name_with_opt_paren(s /,/) ')'
    { 
        $return       = { 
            supertype => 'constraint',
            name      => $item{'index_name(?)'}[0],
            type      => 'unique',
            fields    => $item[5],
        } 
    }

normal_index : KEY index_name(?) '(' name_with_opt_paren(s /,/) ')'
    { 
        $return       = { 
            supertype => 'index',
            type      => 'normal',
            name      => $item{'index_name(?)'}[0],
            fields    => $item[4],
        } 
    }

fulltext_index : /fulltext/i KEY(?) index_name(?) '(' name_with_opt_paren(s /,/) ')'
    { 
        $return       = { 
            supertype => 'index',
            type      => 'fulltext',
            name      => $item{'index_name(?)'}[0],
            fields    => $item[5],
        } 
    }

name_with_opt_paren : NAME parens_value_list(s?)
    { $item[2][0] ? "$item[1]($item[2][0][0])" : $item[1] }

UNIQUE : /unique/i { 1 }

KEY : /key/i | /index/i

table_option : /[^\s;]*/ 
    { 
        $return = { split /=/, $item[1] }
    }

CREATE : /create/i

TEMPORARY : /temporary/i

TABLE : /table/i

WORD : /\w+/

DIGITS : /\d+/

COMMA : ','

NAME    : "`" /\w+/ "`"
    { $item[2] }
    | /\w+/
    { $item[1] }

VALUE   : /[-+]?\.?\d+(?:[eE]\d+)?/
    { $item[1] }
    | /'.*?'/   
    { 
        # remove leading/trailing quotes 
        my $val = $item[1];
        $val    =~ s/^['"]|['"]$//g;
        $return = $val;
    }
    | /NULL/
    { 'NULL' }

!;

# -------------------------------------------------------------------
sub parse {
    my ( $translator, $data ) = @_;
    my $parser = Parse::RecDescent->new($GRAMMAR);

    local $::RD_TRACE  = $translator->trace ? 1 : undef;
    local $DEBUG       = $translator->debug;

    unless (defined $parser) {
        return $translator->error("Error instantiating Parse::RecDescent ".
            "instance: Bad grammer");
    }

    my $result = $parser->startrule($data);
    return $translator->error( "Parse failed." ) unless defined $result;
    warn Dumper( $result ) if $DEBUG;

    my $schema = $translator->schema;
    my @tables = sort { 
        $result->{ $a }->{'order'} <=> $result->{ $b }->{'order'}
    } keys %{ $result };

    for my $table_name ( @tables ) {
        my $tdata =  $result->{ $table_name };
        my $table =  $schema->add_table( 
            name  => $tdata->{'table_name'},
        ) or die $schema->error;

        $table->comments( $tdata->{'comments'} );

        my @fields = sort { 
            $tdata->{'fields'}->{$a}->{'order'} 
            <=>
            $tdata->{'fields'}->{$b}->{'order'}
        } keys %{ $tdata->{'fields'} };

        for my $fname ( @fields ) {
            my $fdata = $tdata->{'fields'}{ $fname };
            my $field = $table->add_field(
                name              => $fdata->{'name'},
                data_type         => $fdata->{'data_type'},
                size              => $fdata->{'size'},
                default_value     => $fdata->{'default'},
                is_auto_increment => $fdata->{'is_auto_inc'},
                is_nullable       => $fdata->{'null'},
                comments          => $fdata->{'comments'},
            ) or die $table->error;

            $table->primary_key( $field->name ) if $fdata->{'is_primary_key'};

            for my $qual ( qw[ binary unsigned zerofill list ] ) {
                if ( my $val = $fdata->{ $qual } || $fdata->{ uc $qual } ) {
                    next if ref $val eq 'ARRAY' && !@$val;
                    $field->extra( $qual, $val );
                }
            }

            if ( $field->data_type =~ /(set|enum)/i && !$field->size ) {
                my %extra = $field->extra;
                my $longest = 0;
                for my $len ( map { length } @{ $extra{'list'} || [] } ) {
                    $longest = $len if $len > $longest;
                }
                $field->size( $longest ) if $longest;
            }

            for my $cdata ( @{ $fdata->{'constraints'} } ) {
                next unless $cdata->{'type'} eq 'foreign_key';
                $cdata->{'fields'} ||= [ $field->name ];
                push @{ $tdata->{'constraints'} }, $cdata;
            }
        }

        for my $idata ( @{ $tdata->{'indices'} || [] } ) {
            my $index  =  $table->add_index(
                name   => $idata->{'name'},
                type   => uc $idata->{'type'},
                fields => $idata->{'fields'},
            ) or die $table->error;
        }

        for my $cdata ( @{ $tdata->{'constraints'} || [] } ) {
            my $constraint       =  $table->add_constraint(
                name             => $cdata->{'name'},
                type             => $cdata->{'type'},
                fields           => $cdata->{'fields'},
                reference_table  => $cdata->{'reference_table'},
                reference_fields => $cdata->{'reference_fields'},
                match_type       => $cdata->{'match_type'} || '',
                on_delete        => $cdata->{'on_delete_do'},
                on_update        => $cdata->{'on_update_do'},
            ) or die $table->error;
        }
    }

    return 1;
}

1;

# -------------------------------------------------------------------
# Where man is not nature is barren.
# William Blake
# -------------------------------------------------------------------

=pod

=head1 AUTHOR

Ken Y. Clark E<lt>kclark@cpan.orgE<gt>,
Chris Mungall E<lt>cjm@fruitfly.orgE<gt>.

=head1 SEE ALSO

perl(1), Parse::RecDescent, SQL::Translator::Schema.

=cut
Commit	Line	Data
16dc9970	1	package SQL::Translator::Parser::MySQL;
16dc9970	2
49e1eb70	3	# -------------------------------------------------------------------
3bfe5e1a	4	# $Id: MySQL.pm,v 1.40 2003-09-08 18:16:04 kycl4rk Exp $
49e1eb70	5	# -------------------------------------------------------------------
abfa405a	6	# Copyright (C) 2003 Ken Y. Clark <kclark@cpan.org>,
	7	# darren chamberlain <darren@cpan.org>,
	8	# Chris Mungall <cjm@fruitfly.org>
077ebf34	9	#
	10	# This program is free software; you can redistribute it and/or
	11	# modify it under the terms of the GNU General Public License as
	12	# published by the Free Software Foundation; version 2.
	13	#
	14	# This program is distributed in the hope that it will be useful, but
	15	# WITHOUT ANY WARRANTY; without even the implied warranty of
	16	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	17	# General Public License for more details.
	18	#
	19	# You should have received a copy of the GNU General Public License
	20	# along with this program; if not, write to the Free Software
	21	# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
	22	# 02111-1307 USA
	23	# -------------------------------------------------------------------
16dc9970	24
d529894e	25	=head1 NAME
	26
	27	SQL::Translator::Parser::MySQL - parser for MySQL
	28
	29	=head1 SYNOPSIS
	30
	31	use SQL::Translator;
	32	use SQL::Translator::Parser::MySQL;
	33
	34	my $translator = SQL::Translator->new;
	35	$translator->parser("SQL::Translator::Parser::MySQL");
	36
	37	=head1 DESCRIPTION
	38
	39	The grammar is influenced heavily by Tim Bunce's "mysql2ora" grammar.
	40
629b76f9	41	Here's the word from the MySQL site
	42	(http://www.mysql.com/doc/en/CREATE_TABLE.html):
	43
	44	CREATE [TEMPORARY] TABLE [IF NOT EXISTS] tbl_name [(create_definition,...)]
	45	[table_options] [select_statement]
	46
	47	or
	48
	49	CREATE [TEMPORARY] TABLE [IF NOT EXISTS] tbl_name LIKE old_table_name;
	50
	51	create_definition:
	52	col_name type [NOT NULL \| NULL] [DEFAULT default_value] [AUTO_INCREMENT]
	53	[PRIMARY KEY] [reference_definition]
	54	or PRIMARY KEY (index_col_name,...)
	55	or KEY [index_name] (index_col_name,...)
	56	or INDEX [index_name] (index_col_name,...)
	57	or UNIQUE [INDEX] [index_name] (index_col_name,...)
	58	or FULLTEXT [INDEX] [index_name] (index_col_name,...)
	59	or [CONSTRAINT symbol] FOREIGN KEY [index_name] (index_col_name,...)
	60	[reference_definition]
	61	or CHECK (expr)
	62
	63	type:
	64	TINYINT[(length)] [UNSIGNED] [ZEROFILL]
	65	or SMALLINT[(length)] [UNSIGNED] [ZEROFILL]
	66	or MEDIUMINT[(length)] [UNSIGNED] [ZEROFILL]
	67	or INT[(length)] [UNSIGNED] [ZEROFILL]
	68	or INTEGER[(length)] [UNSIGNED] [ZEROFILL]
	69	or BIGINT[(length)] [UNSIGNED] [ZEROFILL]
	70	or REAL[(length,decimals)] [UNSIGNED] [ZEROFILL]
	71	or DOUBLE[(length,decimals)] [UNSIGNED] [ZEROFILL]
	72	or FLOAT[(length,decimals)] [UNSIGNED] [ZEROFILL]
	73	or DECIMAL(length,decimals) [UNSIGNED] [ZEROFILL]
	74	or NUMERIC(length,decimals) [UNSIGNED] [ZEROFILL]
	75	or CHAR(length) [BINARY]
	76	or VARCHAR(length) [BINARY]
	77	or DATE
	78	or TIME
	79	or TIMESTAMP
	80	or DATETIME
	81	or TINYBLOB
	82	or BLOB
	83	or MEDIUMBLOB
	84	or LONGBLOB
	85	or TINYTEXT
	86	or TEXT
	87	or MEDIUMTEXT
	88	or LONGTEXT
	89	or ENUM(value1,value2,value3,...)
	90	or SET(value1,value2,value3,...)
	91
	92	index_col_name:
	93	col_name [(length)]
	94
	95	reference_definition:
	96	REFERENCES tbl_name [(index_col_name,...)]
	97	[MATCH FULL \| MATCH PARTIAL]
	98	[ON DELETE reference_option]
	99	[ON UPDATE reference_option]
	100
	101	reference_option:
	102	RESTRICT \| CASCADE \| SET NULL \| NO ACTION \| SET DEFAULT
	103
	104	table_options:
105	TYPE = {BDB \| HEAP \| ISAM \| InnoDB \| MERGE \| MRG_MYISAM \| MYISAM }
106	or AUTO_INCREMENT = #
107	or AVG_ROW_LENGTH = #
108	or CHECKSUM = {0 \| 1}
109	or COMMENT = "string"
110	or MAX_ROWS = #
111	or MIN_ROWS = #
112	or PACK_KEYS = {0 \| 1 \| DEFAULT}
113	or PASSWORD = "string"
114	or DELAY_KEY_WRITE = {0 \| 1}
115	or ROW_FORMAT= { default \| dynamic \| fixed \| compressed }
116	or RAID_TYPE= {1 \| STRIPED \| RAID0 } RAID_CHUNKS=# RAID_CHUNKSIZE=#
117	or UNION = (table_name,[table_name...])
118	or INSERT_METHOD= {NO \| FIRST \| LAST }
119	or DATA DIRECTORY="absolute path to directory"
120	or INDEX DIRECTORY="absolute path to directory"
121
d529894e	122	=cut
d529894e	123
16dc9970	124	use strict;
d529894e	125	use vars qw[ $DEBUG $VERSION $GRAMMAR @EXPORT_OK ];
3bfe5e1a	126	$VERSION = sprintf "%d.%02d", q$Revision: 1.40 $ =~ /(\d+)\.(\d+)/;
8d0f3086	127	$DEBUG = 0 unless defined $DEBUG;
077ebf34	128
d529894e	129	use Data::Dumper;
077ebf34	130	use Parse::RecDescent;
	131	use Exporter;
	132	use base qw(Exporter);
	133
	134	@EXPORT_OK = qw(parse);
	135
d529894e	136	# Enable warnings within the Parse::RecDescent module.
	137	$::RD_ERRORS = 1; # Make sure the parser dies when it encounters an error
	138	$::RD_WARN = 1; # Enable warnings. This will warn on unused rules &c.
	139	$::RD_HINT = 1; # Give out hints to help fix problems.
	140
d529894e	141	$GRAMMAR = q!
d529894e	142
8ccdeb42	143	{
7898fb70	144	my ( %tables, $table_order, @table_comments );
8ccdeb42	145	}
d529894e	146
629b76f9	147	#
	148	# The "eofile" rule makes the parser fail if any "statement" rule
	149	# fails. Otherwise, the first successful match by a "statement"
	150	# won't cause the failure needed to know that the parse, as a whole,
	151	# failed. -ky
	152	#
	153	startrule : statement(s) eofile { \%tables }
	154
	155	eofile : /^\Z/
d529894e	156
d529894e	157	statement : comment
dcb4fa06	158	\| use
33d0d6d4	159	\| set
61745327	160	\| drop
d529894e	161	\| create
	162	\| <error>
	163
dcb4fa06	164	use : /use/i WORD ';'
c5dabd71	165	{ @table_comments = () }
dcb4fa06	166
33d0d6d4	167	set : /set/i /[^;]+/ ';'
c5dabd71	168	{ @table_comments = () }
734dfc91	169
2e8dfb76	170	drop : /drop/i TABLE /[^;]+/ ';'
33d0d6d4	171
61745327	172	drop : /drop/i WORD(s) ';'
c5dabd71	173	{ @table_comments = () }
61745327	174
dcb4fa06	175	create : CREATE /database/i WORD ';'
c5dabd71	176	{ @table_comments = () }
dcb4fa06	177
40c1ade1	178	create : CREATE TEMPORARY(?) TABLE opt_if_not_exists(?) table_name '(' create_definition(s /,/) ')' table_option(s?) ';'
d529894e	179	{
	180	my $table_name = $item{'table_name'};
	181	$tables{ $table_name }{'order'} = ++$table_order;
	182	$tables{ $table_name }{'table_name'} = $table_name;
	183
734dfc91	184	if ( @table_comments ) {
	185	$tables{ $table_name }{'comments'} = [ @table_comments ];
	186	@table_comments = ();
	187	}
	188
61745327	189	my $i = 1;
40c1ade1	190	for my $definition ( @{ $item[7] } ) {
f2cf1734	191	if ( $definition->{'supertype'} eq 'field' ) {
d529894e	192	my $field_name = $definition->{'name'};
	193	$tables{ $table_name }{'fields'}{ $field_name } =
	194	{ %$definition, order => $i };
	195	$i++;
	196
	197	if ( $definition->{'is_primary_key'} ) {
f2cf1734	198	push @{ $tables{ $table_name }{'constraints'} },
d529894e	199	{
	200	type => 'primary_key',
	201	fields => [ $field_name ],
16dc9970	202	}
d529894e	203	;
d529894e	204	}
dd2ef5ae	205	}
f2cf1734	206	elsif ( $definition->{'supertype'} eq 'constraint' ) {
f2cf1734	207	push @{ $tables{ $table_name }{'constraints'} }, $definition;
40c1ade1	208	}
f2cf1734	209	elsif ( $definition->{'supertype'} eq 'index' ) {
734dfc91	210	push @{ $tables{ $table_name }{'indices'} }, $definition;
dd2ef5ae	211	}
d529894e	212	}
dd2ef5ae	213
58a88238	214	for my $opt ( @{ $item{'table_option(s?)'} } ) {
d529894e	215	if ( my ( $key, $val ) = each %$opt ) {
d529894e	216	$tables{ $table_name }{'table_options'}{ $key } = $val;
dd2ef5ae	217	}
d529894e	218	}
58a88238	219
58a88238	220	1;
d529894e	221	}
dd2ef5ae	222
40c1ade1	223	opt_if_not_exists : /if not exists/i
40c1ade1	224
f2cf1734	225	create : CREATE UNIQUE(?) /(index\|key)/i index_name /on/i table_name '(' field_name(s /,/) ')' ';'
d529894e	226	{
734dfc91	227	@table_comments = ();
d529894e	228	push @{ $tables{ $item{'table_name'} }{'indices'} },
	229	{
	230	name => $item[4],
	231	type => $item[2] ? 'unique' : 'normal',
	232	fields => $item[8],
dd2ef5ae	233	}
d529894e	234	;
d529894e	235	}
dd2ef5ae	236
f2cf1734	237	create_definition : constraint
f2cf1734	238	\| index
d529894e	239	\| field
	240	\| <error>
	241
734dfc91	242	comment : /^\s(?:#\|-{2}).\n/
	243	{
	244	my $comment = $item[1];
	245	$comment =~ s/^\s(#\|-{2})\s//;
	246	$comment =~ s/\s*$//;
	247	$return = $comment;
	248	push @table_comments, $comment;
	249	}
	250
	251	field_comment : /^\s(?:#\|-{2}).\n/
	252	{
	253	my $comment = $item[1];
	254	$comment =~ s/^\s(#\|-{2})\s//;
	255	$comment =~ s/\s*$//;
	256	$return = $comment;
	257	}
d529894e	258
	259	blank : /\s*/
	260
734dfc91	261	field : field_comment(s?) field_name data_type field_qualifier(s?) reference_definition(?) field_comment(s?)
d529894e	262	{
734dfc91	263	my %qualifiers = map { %$_ } @{ $item{'field_qualifier(s?)'} \|\| [] };
d529894e	264	if ( my @type_quals = @{ $item{'data_type'}{'qualifiers'} \|\| [] } ) {
	265	$qualifiers{ $_ } = 1 for @type_quals;
	266	}
	267
c5dabd71	268	my $null = defined $qualifiers{'not_null'}
	269	? $qualifiers{'not_null'} : 1;
	270	delete $qualifiers{'not_null'};
	271
88b89793	272	my @comments = ( @{ $item[1] }, @{ $item[6] } );
88b89793	273
d529894e	274	$return = {
f2cf1734	275	supertype => 'field',
	276	name => $item{'field_name'},
	277	data_type => $item{'data_type'}{'type'},
	278	size => $item{'data_type'}{'size'},
	279	list => $item{'data_type'}{'list'},
	280	null => $null,
	281	constraints => $item{'reference_definition(?)'},
88b89793	282	comments => [ @comments ],
d529894e	283	%qualifiers,
	284	}
	285	}
	286	\| <error>
dd2ef5ae	287
d529894e	288	field_qualifier : not_null
	289	{
	290	$return = {
	291	null => $item{'not_null'},
	292	}
	293	}
16dc9970	294
d529894e	295	field_qualifier : default_val
	296	{
	297	$return = {
	298	default => $item{'default_val'},
	299	}
	300	}
16dc9970	301
d529894e	302	field_qualifier : auto_inc
	303	{
	304	$return = {
	305	is_auto_inc => $item{'auto_inc'},
	306	}
	307	}
16dc9970	308
d529894e	309	field_qualifier : primary_key
	310	{
	311	$return = {
	312	is_primary_key => $item{'primary_key'},
	313	}
	314	}
16dc9970	315
d529894e	316	field_qualifier : unsigned
	317	{
	318	$return = {
	319	is_unsigned => $item{'unsigned'},
	320	}
	321	}
16dc9970	322
095b4549	323	field_qualifier : /character set/i WORD
	324	{
	325	$return = {
	326	character_set => $item[2],
	327	}
	328	}
	329
658637cd	330	reference_definition : /references/i table_name parens_field_list(?) match_type(?) on_delete_do(?) on_update_do(?)
658637cd	331	{
40c1ade1	332	$return = {
658637cd	333	type => 'foreign_key',
	334	reference_table => $item[2],
	335	reference_fields => $item[3][0],
	336	match_type => $item[4][0],
	337	on_delete_do => $item[5][0],
	338	on_update_do => $item[6][0],
	339	}
	340	}
	341
	342	match_type : /match full/i { 'match_full' }
	343	\|
	344	/match partial/i { 'match_partial' }
	345
	346	on_delete_do : /on delete/i reference_option
	347	{ $item[2] }
	348
	349	on_update_do : /on update/i reference_option
	350	{ $item[2] }
	351
	352	reference_option: /restrict/i \|
	353	/cascade/i \|
	354	/set null/i \|
	355	/no action/i \|
	356	/set default/i
	357	{ $item[1] }
	358
f2cf1734	359	index : normal_index
371f5f88	360	\| fulltext_index
58a88238	361	\| <error>
d529894e	362
0d41bc9b	363	table_name : NAME
d529894e	364
0d41bc9b	365	field_name : NAME
d529894e	366
	367	index_name : WORD
	368
	369	data_type : WORD parens_value_list(s?) type_qualifier(s?)
	370	{
	371	my $type = $item[1];
	372	my $size; # field size, applicable only to non-set fields
	373	my $list; # set list, applicable only to sets (duh)
	374
44fcd0b5	375	if ( uc($type) =~ /^(SET\|ENUM)$/ ) {
d529894e	376	$size = undef;
	377	$list = $item[2][0];
	378	}
	379	else {
	380	$size = $item[2][0];
	381	$list = [];
	382	}
	383
6333c482	384	unless ( @{ $size \|\| [] } ) {
6333c482	385	if ( lc $type eq 'tinyint' ) {
7898fb70	386	$size = 4;
6333c482	387	}
6333c482	388	elsif ( lc $type eq 'smallint' ) {
7898fb70	389	$size = 6;
6333c482	390	}
6333c482	391	elsif ( lc $type eq 'mediumint' ) {
7898fb70	392	$size = 9;
6333c482	393	}
c736c39c	394	elsif ( $type =~ /^int(eger)?$/ ) {
f2cf1734	395	$type = 'int';
7898fb70	396	$size = 11;
6333c482	397	}
6333c482	398	elsif ( lc $type eq 'bigint' ) {
7898fb70	399	$size = 20;
6333c482	400	}
1eb08c80	401	elsif (
	402	lc $type =~ /(float\|double\|decimal\|numeric\|real\|fixed\|dec)/
	403	) {
6333c482	404	$size = [8,2];
	405	}
	406	}
	407
7898fb70	408	if ( $type =~ /^tiny(text\|blob)$/i ) {
7898fb70	409	$size = 255;
256d534a	410	}
7898fb70	411	elsif ( $type =~ /^(blob\|text)$/i ) {
7898fb70	412	$size = 65_535;
256d534a	413	}
7898fb70	414	elsif ( $type =~ /^medium(blob\|text)$/i ) {
7898fb70	415	$size = 16_777_215;
256d534a	416	}
7898fb70	417	elsif ( $type =~ /^long(blob\|text)$/i ) {
7898fb70	418	$size = 4_294_967_295;
256d534a	419	}
256d534a	420
d529894e	421	$return = {
	422	type => $type,
	423	size => $size,
	424	list => $list,
	425	qualifiers => $item[3],
	426	}
	427	}
16dc9970	428
658637cd	429	parens_field_list : '(' field_name(s /,/) ')'
	430	{ $item[2] }
	431
d529894e	432	parens_value_list : '(' VALUE(s /,/) ')'
d529894e	433	{ $item[2] }
16dc9970	434
d529894e	435	type_qualifier : /(BINARY\|UNSIGNED\|ZEROFILL)/i
d529894e	436	{ lc $item[1] }
16dc9970	437
d529894e	438	field_type : WORD
16dc9970	439
d529894e	440	create_index : /create/i /index/i
dd2ef5ae	441
d529894e	442	not_null : /not/i /null/i { $return = 0 }
16dc9970	443
d529894e	444	unsigned : /unsigned/i { $return = 0 }
16dc9970	445
3bfe5e1a	446	default_val : /default/i /(?:')?[\s\w\d:.-]*(?:')?/
d529894e	447	{
	448	$item[2] =~ s/'//g;
	449	$return = $item[2];
	450	}
16dc9970	451
d529894e	452	auto_inc : /auto_increment/i { 1 }
16dc9970	453
d529894e	454	primary_key : /primary/i /key/i { 1 }
16dc9970	455
f2cf1734	456	constraint : primary_key_def
	457	\| unique_key_def
	458	\| foreign_key_def
	459	\| <error>
	460
026f23b3	461	foreign_key_def : opt_constraint(?) /foreign key/i parens_field_list reference_definition
40c1ade1	462	{
40c1ade1	463	$return = {
f2cf1734	464	supertype => 'constraint',
40c1ade1	465	type => 'foreign_key',
026f23b3	466	name => $item[1][0],
026f23b3	467	fields => $item[3],
40c1ade1	468	%{ $item{'reference_definition'} },
	469	}
	470	}
	471
026f23b3	472	opt_constraint : /constraint/i NAME
026f23b3	473	{ $item[2] }
40c1ade1	474
1853ba82	475	primary_key_def : primary_key index_name(?) '(' name_with_opt_paren(s /,/) ')'
d529894e	476	{
f2cf1734	477	$return = {
	478	supertype => 'constraint',
	479	name => $item{'index_name(?)'}[0],
	480	type => 'primary_key',
	481	fields => $item[4],
58a88238	482	};
d529894e	483	}
16dc9970	484
f2cf1734	485	unique_key_def : UNIQUE KEY(?) index_name(?) '(' name_with_opt_paren(s /,/) ')'
d529894e	486	{
f2cf1734	487	$return = {
	488	supertype => 'constraint',
	489	name => $item{'index_name(?)'}[0],
	490	type => 'unique',
	491	fields => $item[5],
d529894e	492	}
d529894e	493	}
16dc9970	494
f2cf1734	495	normal_index : KEY index_name(?) '(' name_with_opt_paren(s /,/) ')'
d529894e	496	{
f2cf1734	497	$return = {
	498	supertype => 'index',
	499	type => 'normal',
	500	name => $item{'index_name(?)'}[0],
	501	fields => $item[4],
d529894e	502	}
d529894e	503	}
16dc9970	504
f2cf1734	505	fulltext_index : /fulltext/i KEY(?) index_name(?) '(' name_with_opt_paren(s /,/) ')'
371f5f88	506	{
f2cf1734	507	$return = {
	508	supertype => 'index',
	509	type => 'fulltext',
	510	name => $item{'index_name(?)'}[0],
	511	fields => $item[5],
371f5f88	512	}
	513	}
	514
d529894e	515	name_with_opt_paren : NAME parens_value_list(s?)
d529894e	516	{ $item[2][0] ? "$item[1]($item[2][0][0])" : $item[1] }
16dc9970	517
f2cf1734	518	UNIQUE : /unique/i { 1 }
16dc9970	519
f2cf1734	520	KEY : /key/i \| /index/i
16dc9970	521
44fcd0b5	522	table_option : /[^\s;]*/
d529894e	523	{
	524	$return = { split /=/, $item[1] }
	525	}
16dc9970	526
40c1ade1	527	CREATE : /create/i
	528
	529	TEMPORARY : /temporary/i
	530
	531	TABLE : /table/i
	532
d529894e	533	WORD : /\w+/
16dc9970	534
d529894e	535	DIGITS : /\d+/
16dc9970	536
d529894e	537	COMMA : ','
16dc9970	538
d529894e	539	NAME : "`" /\w+/ "`"
	540	{ $item[2] }
	541	\| /\w+/
	542	{ $item[1] }
16dc9970	543
d529894e	544	VALUE : /[-+]?\.?\d+(?:[eE]\d+)?/
d529894e	545	{ $item[1] }
f2cf1734	546	\| /'.*?'/
	547	{
	548	# remove leading/trailing quotes
	549	my $val = $item[1];
	550	$val =~ s/^['"]\|['"]$//g;
	551	$return = $val;
	552	}
d529894e	553	\| /NULL/
d529894e	554	{ 'NULL' }
16dc9970	555
d529894e	556	!;
16dc9970	557
d529894e	558	# -------------------------------------------------------------------
d529894e	559	sub parse {
70944bc5	560	my ( $translator, $data ) = @_;
40c1ade1	561	my $parser = Parse::RecDescent->new($GRAMMAR);
077ebf34	562
e099bee9	563	local $::RD_TRACE = $translator->trace ? 1 : undef;
e099bee9	564	local $DEBUG = $translator->debug;
d529894e	565
	566	unless (defined $parser) {
	567	return $translator->error("Error instantiating Parse::RecDescent ".
	568	"instance: Bad grammer");
	569	}
	570
	571	my $result = $parser->startrule($data);
40c1ade1	572	return $translator->error( "Parse failed." ) unless defined $result;
8ccdeb42	573	warn Dumper( $result ) if $DEBUG;
8ccdeb42	574
70944bc5	575	my $schema = $translator->schema;
034ecdec	576	my @tables = sort {
	577	$result->{ $a }->{'order'} <=> $result->{ $b }->{'order'}
	578	} keys %{ $result };
	579
	580	for my $table_name ( @tables ) {
8ccdeb42	581	my $tdata = $result->{ $table_name };
	582	my $table = $schema->add_table(
	583	name => $tdata->{'table_name'},
40c1ade1	584	) or die $schema->error;
8ccdeb42	585
734dfc91	586	$table->comments( $tdata->{'comments'} );
f2cf1734	587
8ccdeb42	588	my @fields = sort {
	589	$tdata->{'fields'}->{$a}->{'order'}
	590	<=>
	591	$tdata->{'fields'}->{$b}->{'order'}
	592	} keys %{ $tdata->{'fields'} };
	593
	594	for my $fname ( @fields ) {
	595	my $fdata = $tdata->{'fields'}{ $fname };
	596	my $field = $table->add_field(
	597	name => $fdata->{'name'},
	598	data_type => $fdata->{'data_type'},
	599	size => $fdata->{'size'},
	600	default_value => $fdata->{'default'},
	601	is_auto_increment => $fdata->{'is_auto_inc'},
	602	is_nullable => $fdata->{'null'},
88b89793	603	comments => $fdata->{'comments'},
40c1ade1	604	) or die $table->error;
f2cf1734	605
	606	$table->primary_key( $field->name ) if $fdata->{'is_primary_key'};
	607
	608	for my $qual ( qw[ binary unsigned zerofill list ] ) {
	609	if ( my $val = $fdata->{ $qual } \|\| $fdata->{ uc $qual } ) {
	610	next if ref $val eq 'ARRAY' && !@$val;
	611	$field->extra( $qual, $val );
	612	}
	613	}
	614
	615	if ( $field->data_type =~ /(set\|enum)/i && !$field->size ) {
	616	my %extra = $field->extra;
d14fe688	617	my $longest = 0;
f2cf1734	618	for my $len ( map { length } @{ $extra{'list'} \|\| [] } ) {
	619	$longest = $len if $len > $longest;
	620	}
	621	$field->size( $longest ) if $longest;
	622	}
	623
	624	for my $cdata ( @{ $fdata->{'constraints'} } ) {
	625	next unless $cdata->{'type'} eq 'foreign_key';
	626	$cdata->{'fields'} \|\|= [ $field->name ];
	627	push @{ $tdata->{'constraints'} }, $cdata;
	628	}
	629	}
	630
	631	for my $idata ( @{ $tdata->{'indices'} \|\| [] } ) {
	632	my $index = $table->add_index(
	633	name => $idata->{'name'},
	634	type => uc $idata->{'type'},
	635	fields => $idata->{'fields'},
	636	) or die $table->error;
	637	}
	638
	639	for my $cdata ( @{ $tdata->{'constraints'} \|\| [] } ) {
	640	my $constraint = $table->add_constraint(
	641	name => $cdata->{'name'},
	642	type => $cdata->{'type'},
	643	fields => $cdata->{'fields'},
	644	reference_table => $cdata->{'reference_table'},
	645	reference_fields => $cdata->{'reference_fields'},
	646	match_type => $cdata->{'match_type'} \|\| '',
	647	on_delete => $cdata->{'on_delete_do'},
	648	on_update => $cdata->{'on_update_do'},
	649	) or die $table->error;
8ccdeb42	650	}
	651	}
	652
f62bd16c	653	return 1;
d529894e	654	}
	655
	656	1;
	657
034ecdec	658	# -------------------------------------------------------------------
d529894e	659	# Where man is not nature is barren.
d529894e	660	# William Blake
034ecdec	661	# -------------------------------------------------------------------
16dc9970	662
d529894e	663	=pod
16dc9970	664
	665	=head1 AUTHOR
	666
d529894e	667	Ken Y. Clark E<lt>kclark@cpan.orgE<gt>,
8ccdeb42	668	Chris Mungall E<lt>cjm@fruitfly.orgE<gt>.
16dc9970	669
	670	=head1 SEE ALSO
	671
8ccdeb42	672	perl(1), Parse::RecDescent, SQL::Translator::Schema.
16dc9970	673
16dc9970	674	=cut