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

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

# -------------------------------------------------------------------
# $Id: MySQL.pm,v 1.37 2003-08-21 02:38:34 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.37 $ =~ /(\d+)\.(\d+)/;
$DEBUG   = 0 unless defined $DEBUG;

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

@EXPORT_OK = qw(parse);

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

$GRAMMAR = q!

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

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

eofile : /^\Z/

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

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

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

drop : /drop/i TABLE ';'

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

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

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

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

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

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

        1;
    }

opt_if_not_exists : /if not exists/i

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

create_definition : constraint 
    | index
    | field
    | <error>

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

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

blank : /\s*/

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

index : normal_index
    | fulltext_index
    | <error>

table_name   : NAME

field_name   : NAME

index_name   : WORD

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

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

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

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

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

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

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

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

field_type   : WORD

create_index : /create/i /index/i

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

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

default_val  : /default/i /(?:')?[\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;

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

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

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

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

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

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

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

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

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

    return 1;
}

1;

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

=pod

=head1 AUTHOR

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

=head1 SEE ALSO

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

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