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

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

# -------------------------------------------------------------------
# $Id: MySQL.pm,v 1.34 2003-08-19 14:41:05 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.34 $ =~ /(\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!

{ 
    our ( %tables, $table_order );
}

#
# 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 ';'

set : /set/i /[^;]+/ ';'

drop : /drop/i WORD(s) ';'

create : CREATE /database/i WORD ';'

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;

        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' ) {
                # prob get rid of this?
#                for my $field ( @{ $definition->{'fields'} } ) {
#                    push @{ 
#                        $tables{$table_name}{'fields'}{$field}{'constraints'}
#                    },
#                    $definition; 
#                }

                # this should be the only one needed
                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 /,/) ')' ';'
    {
        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;
}

blank : /\s*/

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

        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 ( lc $type eq 'tinytext' ) {
            $size = [255];
        }
        elsif ( lc $type eq 'text' ) {
            $size = [65_000];
        }
        elsif ( lc $type eq 'mediumtext' ) {
            $size = [16_000_000];
        }
        elsif ( lc $type eq 'longtext' ) {
            $size = [4_000_000_000];
        }

        $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 /(?:')?[\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 WORD(?) parens_field_list reference_definition
    {
        $return              =  {
            supertype        => 'constraint',
            type             => 'foreign_key',
            name             => $item[3][0],
            fields           => $item[4],
            %{ $item{'reference_definition'} },
        }
    }

opt_constraint : /constraint/i WORD

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;

#        for my $opt ( @{ $tdata->{'table_options'} } ) {
#            if ( my ( $key, $val ) = each %$opt ) {
#                $tables->options( 
#            }
#        }

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