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

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

# -------------------------------------------------------------------
# $Id: MySQL.pm,v 1.42 2004-01-25 18:09:51 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.42 $ =~ /(\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;
            }
        }

        if ( my @options = @{ $item{'table_option(s?)'} } ) {
            $tables{ $table_name }{'table_options'} = \@options;
        }

        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
    | comment
    | <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 { 'full' }
    |
    /match partial/i { '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   : NAME

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];
#    }

default_val : /default/i /'(?:.*?\\')*.*?'|(?:')?[\w\d:.-]*(?:')?/
    {
        $item[2] =~ s/^\s*'|'\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 : foreign_key_def_begin parens_field_list reference_definition
    {
        $return              =  {
            supertype        => 'constraint',
            type             => 'foreign_key',
            name             => $item[1],
            fields           => $item[2],
            %{ $item{'reference_definition'} },
        }
    }

foreign_key_def_begin : /constraint/i /foreign key/i 
    { $return = '' }
    |
    /constraint/i WORD /foreign key/i
    { $return = $item[2] }
    |
    /foreign key/i
    { $return = '' }

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 : WORD /\s*=\s*/ WORD
    { 
        $return = { $item[1] => $item[3] };
    }

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;
        }

        if ( my @options = @{ $tdata->{'table_options'} || [] } ) {
            $table->options( \@options ) 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	# -------------------------------------------------------------------
09fa21a6	4	# $Id: MySQL.pm,v 1.42 2004-01-25 18:09:51 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 ];
09fa21a6	126	$VERSION = sprintf "%d.%02d", q$Revision: 1.42 $ =~ /(\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
02a21f1a	214	if ( my @options = @{ $item{'table_option(s?)'} } ) {
02a21f1a	215	$tables{ $table_name }{'table_options'} = \@options;
d529894e	216	}
58a88238	217
58a88238	218	1;
d529894e	219	}
dd2ef5ae	220
40c1ade1	221	opt_if_not_exists : /if not exists/i
40c1ade1	222
f2cf1734	223	create : CREATE UNIQUE(?) /(index\|key)/i index_name /on/i table_name '(' field_name(s /,/) ')' ';'
d529894e	224	{
734dfc91	225	@table_comments = ();
d529894e	226	push @{ $tables{ $item{'table_name'} }{'indices'} },
	227	{
	228	name => $item[4],
	229	type => $item[2] ? 'unique' : 'normal',
	230	fields => $item[8],
dd2ef5ae	231	}
d529894e	232	;
d529894e	233	}
dd2ef5ae	234
f2cf1734	235	create_definition : constraint
f2cf1734	236	\| index
d529894e	237	\| field
02a21f1a	238	\| comment
d529894e	239	\| <error>
d529894e	240
734dfc91	241	comment : /^\s(?:#\|-{2}).\n/
	242	{
	243	my $comment = $item[1];
	244	$comment =~ s/^\s(#\|-{2})\s//;
	245	$comment =~ s/\s*$//;
	246	$return = $comment;
	247	push @table_comments, $comment;
	248	}
	249
	250	field_comment : /^\s(?:#\|-{2}).\n/
	251	{
	252	my $comment = $item[1];
	253	$comment =~ s/^\s(#\|-{2})\s//;
	254	$comment =~ s/\s*$//;
	255	$return = $comment;
	256	}
d529894e	257
	258	blank : /\s*/
	259
734dfc91	260	field : field_comment(s?) field_name data_type field_qualifier(s?) reference_definition(?) field_comment(s?)
d529894e	261	{
734dfc91	262	my %qualifiers = map { %$_ } @{ $item{'field_qualifier(s?)'} \|\| [] };
d529894e	263	if ( my @type_quals = @{ $item{'data_type'}{'qualifiers'} \|\| [] } ) {
	264	$qualifiers{ $_ } = 1 for @type_quals;
	265	}
	266
c5dabd71	267	my $null = defined $qualifiers{'not_null'}
	268	? $qualifiers{'not_null'} : 1;
	269	delete $qualifiers{'not_null'};
	270
88b89793	271	my @comments = ( @{ $item[1] }, @{ $item[6] } );
88b89793	272
d529894e	273	$return = {
f2cf1734	274	supertype => 'field',
	275	name => $item{'field_name'},
	276	data_type => $item{'data_type'}{'type'},
	277	size => $item{'data_type'}{'size'},
	278	list => $item{'data_type'}{'list'},
	279	null => $null,
	280	constraints => $item{'reference_definition(?)'},
88b89793	281	comments => [ @comments ],
d529894e	282	%qualifiers,
	283	}
	284	}
	285	\| <error>
dd2ef5ae	286
d529894e	287	field_qualifier : not_null
	288	{
	289	$return = {
	290	null => $item{'not_null'},
	291	}
	292	}
16dc9970	293
d529894e	294	field_qualifier : default_val
	295	{
	296	$return = {
	297	default => $item{'default_val'},
	298	}
	299	}
16dc9970	300
d529894e	301	field_qualifier : auto_inc
	302	{
	303	$return = {
	304	is_auto_inc => $item{'auto_inc'},
	305	}
	306	}
16dc9970	307
d529894e	308	field_qualifier : primary_key
	309	{
	310	$return = {
	311	is_primary_key => $item{'primary_key'},
	312	}
	313	}
16dc9970	314
d529894e	315	field_qualifier : unsigned
	316	{
	317	$return = {
	318	is_unsigned => $item{'unsigned'},
	319	}
	320	}
16dc9970	321
095b4549	322	field_qualifier : /character set/i WORD
	323	{
	324	$return = {
	325	character_set => $item[2],
	326	}
	327	}
	328
658637cd	329	reference_definition : /references/i table_name parens_field_list(?) match_type(?) on_delete_do(?) on_update_do(?)
658637cd	330	{
40c1ade1	331	$return = {
658637cd	332	type => 'foreign_key',
	333	reference_table => $item[2],
	334	reference_fields => $item[3][0],
	335	match_type => $item[4][0],
	336	on_delete_do => $item[5][0],
	337	on_update_do => $item[6][0],
	338	}
	339	}
	340
02a21f1a	341	match_type : /match full/i { 'full' }
658637cd	342	\|
02a21f1a	343	/match partial/i { 'partial' }
658637cd	344
	345	on_delete_do : /on delete/i reference_option
	346	{ $item[2] }
	347
	348	on_update_do : /on update/i reference_option
	349	{ $item[2] }
	350
	351	reference_option: /restrict/i \|
	352	/cascade/i \|
	353	/set null/i \|
	354	/no action/i \|
	355	/set default/i
	356	{ $item[1] }
	357
f2cf1734	358	index : normal_index
371f5f88	359	\| fulltext_index
58a88238	360	\| <error>
d529894e	361
0d41bc9b	362	table_name : NAME
d529894e	363
0d41bc9b	364	field_name : NAME
d529894e	365
02a21f1a	366	index_name : NAME
d529894e	367
	368	data_type : WORD parens_value_list(s?) type_qualifier(s?)
	369	{
	370	my $type = $item[1];
	371	my $size; # field size, applicable only to non-set fields
	372	my $list; # set list, applicable only to sets (duh)
	373
44fcd0b5	374	if ( uc($type) =~ /^(SET\|ENUM)$/ ) {
d529894e	375	$size = undef;
	376	$list = $item[2][0];
	377	}
	378	else {
	379	$size = $item[2][0];
	380	$list = [];
	381	}
	382
6333c482	383	unless ( @{ $size \|\| [] } ) {
6333c482	384	if ( lc $type eq 'tinyint' ) {
7898fb70	385	$size = 4;
6333c482	386	}
6333c482	387	elsif ( lc $type eq 'smallint' ) {
7898fb70	388	$size = 6;
6333c482	389	}
6333c482	390	elsif ( lc $type eq 'mediumint' ) {
7898fb70	391	$size = 9;
6333c482	392	}
c736c39c	393	elsif ( $type =~ /^int(eger)?$/ ) {
f2cf1734	394	$type = 'int';
7898fb70	395	$size = 11;
6333c482	396	}
6333c482	397	elsif ( lc $type eq 'bigint' ) {
7898fb70	398	$size = 20;
6333c482	399	}
1eb08c80	400	elsif (
	401	lc $type =~ /(float\|double\|decimal\|numeric\|real\|fixed\|dec)/
	402	) {
6333c482	403	$size = [8,2];
	404	}
	405	}
	406
7898fb70	407	if ( $type =~ /^tiny(text\|blob)$/i ) {
7898fb70	408	$size = 255;
256d534a	409	}
7898fb70	410	elsif ( $type =~ /^(blob\|text)$/i ) {
7898fb70	411	$size = 65_535;
256d534a	412	}
7898fb70	413	elsif ( $type =~ /^medium(blob\|text)$/i ) {
7898fb70	414	$size = 16_777_215;
256d534a	415	}
7898fb70	416	elsif ( $type =~ /^long(blob\|text)$/i ) {
7898fb70	417	$size = 4_294_967_295;
256d534a	418	}
256d534a	419
d529894e	420	$return = {
	421	type => $type,
	422	size => $size,
	423	list => $list,
	424	qualifiers => $item[3],
	425	}
	426	}
16dc9970	427
658637cd	428	parens_field_list : '(' field_name(s /,/) ')'
	429	{ $item[2] }
	430
d529894e	431	parens_value_list : '(' VALUE(s /,/) ')'
d529894e	432	{ $item[2] }
16dc9970	433
d529894e	434	type_qualifier : /(BINARY\|UNSIGNED\|ZEROFILL)/i
d529894e	435	{ lc $item[1] }
16dc9970	436
d529894e	437	field_type : WORD
16dc9970	438
d529894e	439	create_index : /create/i /index/i
dd2ef5ae	440
d529894e	441	not_null : /not/i /null/i { $return = 0 }
16dc9970	442
d529894e	443	unsigned : /unsigned/i { $return = 0 }
16dc9970	444
09fa21a6	445	#default_val : /default/i /(?:')?[\s\w\d:.-]*(?:')?/
	446	# {
	447	# $item[2] =~ s/'//g;
	448	# $return = $item[2];
	449	# }
	450
	451	default_val : /default/i /'(?:.?\\').?'\|(?:')?[\w\d:.-](?:')?/
	452	{
	453	$item[2] =~ s/^\s'\|'\s$//g;
d529894e	454	$return = $item[2];
d529894e	455	}
16dc9970	456
d529894e	457	auto_inc : /auto_increment/i { 1 }
16dc9970	458
d529894e	459	primary_key : /primary/i /key/i { 1 }
16dc9970	460
f2cf1734	461	constraint : primary_key_def
	462	\| unique_key_def
	463	\| foreign_key_def
	464	\| <error>
	465
02a21f1a	466	foreign_key_def : foreign_key_def_begin parens_field_list reference_definition
40c1ade1	467	{
40c1ade1	468	$return = {
f2cf1734	469	supertype => 'constraint',
40c1ade1	470	type => 'foreign_key',
02a21f1a	471	name => $item[1],
09fa21a6	472	fields => $item[2],
40c1ade1	473	%{ $item{'reference_definition'} },
	474	}
	475	}
	476
02a21f1a	477	foreign_key_def_begin : /constraint/i /foreign key/i
	478	{ $return = '' }
	479	\|
	480	/constraint/i WORD /foreign key/i
	481	{ $return = $item[2] }
	482	\|
	483	/foreign key/i
	484	{ $return = '' }
40c1ade1	485
1853ba82	486	primary_key_def : primary_key index_name(?) '(' name_with_opt_paren(s /,/) ')'
d529894e	487	{
f2cf1734	488	$return = {
	489	supertype => 'constraint',
	490	name => $item{'index_name(?)'}[0],
	491	type => 'primary_key',
	492	fields => $item[4],
58a88238	493	};
d529894e	494	}
16dc9970	495
f2cf1734	496	unique_key_def : UNIQUE KEY(?) index_name(?) '(' name_with_opt_paren(s /,/) ')'
d529894e	497	{
f2cf1734	498	$return = {
	499	supertype => 'constraint',
	500	name => $item{'index_name(?)'}[0],
	501	type => 'unique',
	502	fields => $item[5],
d529894e	503	}
d529894e	504	}
16dc9970	505
f2cf1734	506	normal_index : KEY index_name(?) '(' name_with_opt_paren(s /,/) ')'
d529894e	507	{
f2cf1734	508	$return = {
	509	supertype => 'index',
	510	type => 'normal',
	511	name => $item{'index_name(?)'}[0],
	512	fields => $item[4],
d529894e	513	}
d529894e	514	}
16dc9970	515
f2cf1734	516	fulltext_index : /fulltext/i KEY(?) index_name(?) '(' name_with_opt_paren(s /,/) ')'
371f5f88	517	{
f2cf1734	518	$return = {
	519	supertype => 'index',
	520	type => 'fulltext',
	521	name => $item{'index_name(?)'}[0],
	522	fields => $item[5],
371f5f88	523	}
	524	}
	525
d529894e	526	name_with_opt_paren : NAME parens_value_list(s?)
d529894e	527	{ $item[2][0] ? "$item[1]($item[2][0][0])" : $item[1] }
16dc9970	528
f2cf1734	529	UNIQUE : /unique/i { 1 }
16dc9970	530
f2cf1734	531	KEY : /key/i \| /index/i
16dc9970	532
02a21f1a	533	table_option : WORD /\s=\s/ WORD
d529894e	534	{
02a21f1a	535	$return = { $item[1] => $item[3] };
d529894e	536	}
16dc9970	537
40c1ade1	538	CREATE : /create/i
	539
	540	TEMPORARY : /temporary/i
	541
	542	TABLE : /table/i
	543
d529894e	544	WORD : /\w+/
16dc9970	545
d529894e	546	DIGITS : /\d+/
16dc9970	547
d529894e	548	COMMA : ','
16dc9970	549
d529894e	550	NAME : "`" /\w+/ "`"
	551	{ $item[2] }
	552	\| /\w+/
	553	{ $item[1] }
16dc9970	554
d529894e	555	VALUE : /[-+]?\.?\d+(?:[eE]\d+)?/
d529894e	556	{ $item[1] }
f2cf1734	557	\| /'.*?'/
	558	{
	559	# remove leading/trailing quotes
	560	my $val = $item[1];
	561	$val =~ s/^['"]\|['"]$//g;
	562	$return = $val;
	563	}
d529894e	564	\| /NULL/
d529894e	565	{ 'NULL' }
16dc9970	566
d529894e	567	!;
16dc9970	568
d529894e	569	# -------------------------------------------------------------------
d529894e	570	sub parse {
70944bc5	571	my ( $translator, $data ) = @_;
40c1ade1	572	my $parser = Parse::RecDescent->new($GRAMMAR);
077ebf34	573
e099bee9	574	local $::RD_TRACE = $translator->trace ? 1 : undef;
e099bee9	575	local $DEBUG = $translator->debug;
d529894e	576
	577	unless (defined $parser) {
	578	return $translator->error("Error instantiating Parse::RecDescent ".
	579	"instance: Bad grammer");
	580	}
	581
	582	my $result = $parser->startrule($data);
40c1ade1	583	return $translator->error( "Parse failed." ) unless defined $result;
8ccdeb42	584	warn Dumper( $result ) if $DEBUG;
8ccdeb42	585
70944bc5	586	my $schema = $translator->schema;
034ecdec	587	my @tables = sort {
	588	$result->{ $a }->{'order'} <=> $result->{ $b }->{'order'}
	589	} keys %{ $result };
	590
	591	for my $table_name ( @tables ) {
8ccdeb42	592	my $tdata = $result->{ $table_name };
	593	my $table = $schema->add_table(
	594	name => $tdata->{'table_name'},
40c1ade1	595	) or die $schema->error;
8ccdeb42	596
734dfc91	597	$table->comments( $tdata->{'comments'} );
f2cf1734	598
8ccdeb42	599	my @fields = sort {
	600	$tdata->{'fields'}->{$a}->{'order'}
	601	<=>
	602	$tdata->{'fields'}->{$b}->{'order'}
	603	} keys %{ $tdata->{'fields'} };
	604
	605	for my $fname ( @fields ) {
	606	my $fdata = $tdata->{'fields'}{ $fname };
	607	my $field = $table->add_field(
	608	name => $fdata->{'name'},
	609	data_type => $fdata->{'data_type'},
	610	size => $fdata->{'size'},
	611	default_value => $fdata->{'default'},
	612	is_auto_increment => $fdata->{'is_auto_inc'},
	613	is_nullable => $fdata->{'null'},
88b89793	614	comments => $fdata->{'comments'},
40c1ade1	615	) or die $table->error;
f2cf1734	616
	617	$table->primary_key( $field->name ) if $fdata->{'is_primary_key'};
	618
	619	for my $qual ( qw[ binary unsigned zerofill list ] ) {
	620	if ( my $val = $fdata->{ $qual } \|\| $fdata->{ uc $qual } ) {
	621	next if ref $val eq 'ARRAY' && !@$val;
	622	$field->extra( $qual, $val );
	623	}
	624	}
	625
	626	if ( $field->data_type =~ /(set\|enum)/i && !$field->size ) {
	627	my %extra = $field->extra;
d14fe688	628	my $longest = 0;
f2cf1734	629	for my $len ( map { length } @{ $extra{'list'} \|\| [] } ) {
	630	$longest = $len if $len > $longest;
	631	}
	632	$field->size( $longest ) if $longest;
	633	}
	634
	635	for my $cdata ( @{ $fdata->{'constraints'} } ) {
	636	next unless $cdata->{'type'} eq 'foreign_key';
	637	$cdata->{'fields'} \|\|= [ $field->name ];
	638	push @{ $tdata->{'constraints'} }, $cdata;
	639	}
	640	}
	641
	642	for my $idata ( @{ $tdata->{'indices'} \|\| [] } ) {
	643	my $index = $table->add_index(
	644	name => $idata->{'name'},
	645	type => uc $idata->{'type'},
	646	fields => $idata->{'fields'},
	647	) or die $table->error;
	648	}
	649
02a21f1a	650	if ( my @options = @{ $tdata->{'table_options'} \|\| [] } ) {
	651	$table->options( \@options ) or die $table->error;
	652	}
	653
f2cf1734	654	for my $cdata ( @{ $tdata->{'constraints'} \|\| [] } ) {
	655	my $constraint = $table->add_constraint(
	656	name => $cdata->{'name'},
	657	type => $cdata->{'type'},
	658	fields => $cdata->{'fields'},
	659	reference_table => $cdata->{'reference_table'},
	660	reference_fields => $cdata->{'reference_fields'},
	661	match_type => $cdata->{'match_type'} \|\| '',
	662	on_delete => $cdata->{'on_delete_do'},
	663	on_update => $cdata->{'on_update_do'},
	664	) or die $table->error;
8ccdeb42	665	}
	666	}
	667
f62bd16c	668	return 1;
d529894e	669	}
	670
	671	1;
	672
034ecdec	673	# -------------------------------------------------------------------
d529894e	674	# Where man is not nature is barren.
d529894e	675	# William Blake
034ecdec	676	# -------------------------------------------------------------------
16dc9970	677
d529894e	678	=pod
16dc9970	679
	680	=head1 AUTHOR
	681
d529894e	682	Ken Y. Clark E<lt>kclark@cpan.orgE<gt>,
8ccdeb42	683	Chris Mungall E<lt>cjm@fruitfly.orgE<gt>.
16dc9970	684
	685	=head1 SEE ALSO
	686
8ccdeb42	687	perl(1), Parse::RecDescent, SQL::Translator::Schema.
16dc9970	688
16dc9970	689	=cut