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

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

# -------------------------------------------------------------------
# $Id: MySQL.pm,v 1.25 2003-06-11 03:59:49 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.25 $ =~ /(\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/

blank : /\s*/

field : field_name data_type field_qualifier(s?) reference_definition(?)
    { 
        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;
        }

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