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

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

# -------------------------------------------------------------------
# $Id: MySQL.pm,v 1.26 2003-07-18 22:56:12 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.26 $ =~ /(\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
    | drop
    | create
    | <error>

use : /use/i WORD ';'

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})//;
    $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'},
        } 
    }

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   : WORD

field_name   : WORD

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)/ ) {
                $size = [8,2];
            }
        }

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