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

package SQL::Translator::Parser::Access;

# -------------------------------------------------------------------
# $Id: Access.pm,v 1.1 2004-04-19 16:38:17 kycl4rk Exp $
# -------------------------------------------------------------------
# Copyright (C) 2002-4 SQLFairy Authors
#
# 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::Access - parser for Access as produced by mdbtools

=head1 SYNOPSIS

  use SQL::Translator;
  use SQL::Translator::Parser::Access;

  my $translator = SQL::Translator->new;
  $translator->parser("SQL::Translator::Parser::Access");

=head1 DESCRIPTION

The grammar derived from the MySQL grammar.  The input is expected to be 
something similar to the output of mdbtools (http://mdbtools.sourceforge.net/).

=cut

use strict;
use vars qw[ $DEBUG $VERSION $GRAMMAR @EXPORT_OK ];
$VERSION = sprintf "%d.%02d", q$Revision: 1.1 $ =~ /(\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 TABLE table_name '(' create_definition(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[5] } ) {
            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;
            }
        }

        1;
    }

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

create_definition : constraint 
    | index
    | field
    | comment
    | <error>

comment : /^\s*--(.*)\n/ 
    { 
        my $comment =  $1;
        $return     = $comment;
        push @table_comments, $comment;
    }

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

        $return = { 
            supertype   => 'field',
            name        => $item{'field_name'}, 
            data_type   => $item{'data_type'}{'type'},
            size        => $item{'data_type'}{'size'},
#            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'},
        } 
    }

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

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

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

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

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

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

index : normal_index
    | fulltext_index
    | <error>

table_name   : NAME

field_name   : NAME

index_name   : NAME

data_type    : access_data_type parens_value_list(s?) type_qualifier(s?)
    { 
        $return        = { 
            type       => $item[1],
            size       => $item[2][0],
            qualifiers => $item[3],
        } 
    }

access_data_type : /long integer/i { $return = 'Long Integer' }
    | /text/i { $return = 'Text' }
    | /datetime (\(short\))?/i { $return = 'DateTime' }
    | /boolean/i { $return = 'Boolean' }
    | WORD

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/^\s*'|'\s*$//g;
        $return  =  $item[2];
    }

auto_inc : /auto_increment/i { 1 }

primary_key : /primary/i /key/i { 1 }

constraint : primary_key_def
    | unique_key_def
    | foreign_key_def
    | <error>

foreign_key_def : foreign_key_def_begin parens_field_list reference_definition
    {
        $return              =  {
            supertype        => 'constraint',
            type             => 'foreign_key',
            name             => $item[1],
            fields           => $item[2],
            %{ $item{'reference_definition'} },
        }
    }

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

primary_key_def : primary_key index_name(?) '(' name_with_opt_paren(s /,/) ')'
    { 
        $return       = { 
            supertype => 'constraint',
            name      => $item{'index_name(?)'}[0],
            type      => 'primary_key',
            fields    => $item[4],
        };
    }

unique_key_def : UNIQUE KEY(?) index_name(?) '(' name_with_opt_paren(s /,/) ')'
    { 
        $return       = { 
            supertype => 'constraint',
            name      => $item{'index_name(?)'}[0],
            type      => 'unique',
            fields    => $item[5],
        } 
    }

normal_index : KEY index_name(?) '(' name_with_opt_paren(s /,/) ')'
    { 
        $return       = { 
            supertype => 'index',
            type      => 'normal',
            name      => $item{'index_name(?)'}[0],
            fields    => $item[4],
        } 
    }

fulltext_index : /fulltext/i KEY(?) index_name(?) '(' name_with_opt_paren(s /,/) ')'
    { 
        $return       = { 
            supertype => 'index',
            type      => 'fulltext',
            name      => $item{'index_name(?)'}[0],
            fields    => $item[5],
        } 
    }

name_with_opt_paren : NAME parens_value_list(s?)
    { $item[2][0] ? "$item[1]($item[2][0][0])" : $item[1] }

UNIQUE : /unique/i { 1 }

KEY : /key/i | /index/i

table_option : WORD /\s*=\s*/ WORD
    { 
        $return = { $item[1] => $item[3] };
    }

CREATE : /create/i

TEMPORARY : /temporary/i

TABLE : /table/i

WORD : /\w+/

DIGITS : /\d+/

COMMA : ','

NAME    : "`" /\w+/ "`"
    { $item[2] }
    | /\w+/
    { $item[1] }

VALUE   : /[-+]?\.?\d+(?:[eE]\d+)?/
    { $item[1] }
    | /'.*?'/   
    { 
        # remove leading/trailing quotes 
        my $val = $item[1];
        $val    =~ s/^['"]|['"]$//g;
        $return = $val;
    }
    | /NULL/
    { 'NULL' }

!;

# -------------------------------------------------------------------
sub parse {
    my ( $translator, $data ) = @_;
    my $parser = Parse::RecDescent->new($GRAMMAR);

    local $::RD_TRACE  = $translator->trace ? 1 : undef;
    local $DEBUG       = $translator->debug;

    unless (defined $parser) {
        return $translator->error("Error instantiating Parse::RecDescent ".
            "instance: Bad grammer");
    }

    my $result = $parser->startrule($data);
    return $translator->error( "Parse failed." ) unless defined $result;
    warn Dumper( $result ) if $DEBUG;

    my $schema = $translator->schema;
    my @tables = sort { 
        $result->{ $a }->{'order'} <=> $result->{ $b }->{'order'}
    } keys %{ $result };

    for my $table_name ( @tables ) {
        my $tdata =  $result->{ $table_name };
        my $table =  $schema->add_table( 
            name  => $tdata->{'table_name'},
        ) or die $schema->error;

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

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

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

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

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

#            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>.

=head1 SEE ALSO

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

=cut
Commit	Line	Data
7c44825c	1	package SQL::Translator::Parser::Access;
	2
	3	# -------------------------------------------------------------------
	4	# $Id: Access.pm,v 1.1 2004-04-19 16:38:17 kycl4rk Exp $
	5	# -------------------------------------------------------------------
	6	# Copyright (C) 2002-4 SQLFairy Authors
	7	#
	8	# This program is free software; you can redistribute it and/or
	9	# modify it under the terms of the GNU General Public License as
	10	# published by the Free Software Foundation; version 2.
	11	#
	12	# This program is distributed in the hope that it will be useful, but
	13	# WITHOUT ANY WARRANTY; without even the implied warranty of
	14	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	15	# General Public License for more details.
	16	#
	17	# You should have received a copy of the GNU General Public License
	18	# along with this program; if not, write to the Free Software
	19	# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
	20	# 02111-1307 USA
	21	# -------------------------------------------------------------------
	22
	23	=head1 NAME
	24
	25	SQL::Translator::Parser::Access - parser for Access as produced by mdbtools
	26
	27	=head1 SYNOPSIS
	28
	29	use SQL::Translator;
	30	use SQL::Translator::Parser::Access;
	31
	32	my $translator = SQL::Translator->new;
	33	$translator->parser("SQL::Translator::Parser::Access");
	34
	35	=head1 DESCRIPTION
	36
	37	The grammar derived from the MySQL grammar. The input is expected to be
	38	something similar to the output of mdbtools (http://mdbtools.sourceforge.net/).
	39
	40	=cut
	41
	42	use strict;
	43	use vars qw[ $DEBUG $VERSION $GRAMMAR @EXPORT_OK ];
	44	$VERSION = sprintf "%d.%02d", q$Revision: 1.1 $ =~ /(\d+)\.(\d+)/;
	45	$DEBUG = 0 unless defined $DEBUG;
	46
	47	use Data::Dumper;
	48	use Parse::RecDescent;
	49	use Exporter;
	50	use base qw(Exporter);
	51
	52	@EXPORT_OK = qw(parse);
	53
	54	# Enable warnings within the Parse::RecDescent module.
	55	$::RD_ERRORS = 1; # Make sure the parser dies when it encounters an error
	56	$::RD_WARN = 1; # Enable warnings. This will warn on unused rules &c.
	57	$::RD_HINT = 1; # Give out hints to help fix problems.
	58
	59	$GRAMMAR = q!
	60
	61	{
	62	my ( %tables, $table_order, @table_comments );
	63	}
	64
65	#
66	# The "eofile" rule makes the parser fail if any "statement" rule
67	# fails. Otherwise, the first successful match by a "statement"
68	# won't cause the failure needed to know that the parse, as a whole,
69	# failed. -ky
70	#
71	startrule : statement(s) eofile { \%tables }
72
73	eofile : /^\Z/
74
75	statement : comment
76	\| use
77	\| set
78	\| drop
79	\| create
80	\| <error>
81
82	use : /use/i WORD ';'
83	{ @table_comments = () }
84
85	set : /set/i /[^;]+/ ';'
86	{ @table_comments = () }
87
88	drop : /drop/i TABLE /[^;]+/ ';'
89
90	drop : /drop/i WORD(s) ';'
91	{ @table_comments = () }
92
93	create : CREATE /database/i WORD ';'
94	{ @table_comments = () }
95
96	create : CREATE TABLE table_name '(' create_definition(s /,/) ')' ';'
97	{
98	my $table_name = $item{'table_name'};
99	$tables{ $table_name }{'order'} = ++$table_order;
100	$tables{ $table_name }{'table_name'} = $table_name;
101
102	if ( @table_comments ) {
103	$tables{ $table_name }{'comments'} = [ @table_comments ];
104	@table_comments = ();
105	}
106
107	my $i = 1;
108	for my $definition ( @{ $item[5] } ) {
109	if ( $definition->{'supertype'} eq 'field' ) {
110	my $field_name = $definition->{'name'};
111	$tables{ $table_name }{'fields'}{ $field_name } =
112	{ %$definition, order => $i };
113	$i++;
114
115	if ( $definition->{'is_primary_key'} ) {
116	push @{ $tables{ $table_name }{'constraints'} },
117	{
118	type => 'primary_key',
119	fields => [ $field_name ],
120	}
121	;
122	}
123	}
124	elsif ( $definition->{'supertype'} eq 'constraint' ) {
125	push @{ $tables{ $table_name }{'constraints'} }, $definition;
126	}
127	elsif ( $definition->{'supertype'} eq 'index' ) {
128	push @{ $tables{ $table_name }{'indices'} }, $definition;
129	}
130	}
131
132	1;
133	}
134
135	create : CREATE UNIQUE(?) /(index\|key)/i index_name /on/i table_name '(' field_name(s /,/) ')' ';'
136	{
137	@table_comments = ();
138	push @{ $tables{ $item{'table_name'} }{'indices'} },
139	{
140	name => $item[4],
141	type => $item[2] ? 'unique' : 'normal',
142	fields => $item[8],
143	}
144	;
145	}
146
147	create_definition : constraint
148	\| index
149	\| field
150	\| comment
151	\| <error>
152
153	comment : /^\s--(.)\n/
154	{
155	my $comment = $1;
156	$return = $comment;
157	push @table_comments, $comment;
158	}
159
160	field : field_name data_type field_qualifier(s?) reference_definition(?)
161	{
162	# my %qualifiers = map { %$_ } @{ $item{'field_qualifier(s?)'} \|\| [] };
163	# if ( my @type_quals = @{ $item{'data_type'}{'qualifiers'} \|\| [] } ) {
164	# $qualifiers{ $_ } = 1 for @type_quals;
165	# }
166	#
167	# my $null = defined $qualifiers{'not_null'}
168	# ? $qualifiers{'not_null'} : 1;
169	# delete $qualifiers{'not_null'};
170
171	$return = {
172	supertype => 'field',
173	name => $item{'field_name'},
174	data_type => $item{'data_type'}{'type'},
175	size => $item{'data_type'}{'size'},
176	# null => $null,
177	constraints => $item{'reference_definition(?)'},
178	# %qualifiers,
179	}
180	}
181	\| <error>
182
183	field_qualifier : not_null
184	{
185	$return = {
186	null => $item{'not_null'},
187	}
188	}
189
190	field_qualifier : default_val
191	{
192	$return = {
193	default => $item{'default_val'},
194	}
195	}
196
197	field_qualifier : auto_inc
198	{
199	$return = {
200	is_auto_inc => $item{'auto_inc'},
201	}
202	}
203
204	field_qualifier : primary_key
205	{
206	$return = {
207	is_primary_key => $item{'primary_key'},
208	}
209	}
210
211	field_qualifier : unsigned
212	{
213	$return = {
214	is_unsigned => $item{'unsigned'},
215	}
216	}
217
218	field_qualifier : /character set/i WORD
219	{
220	$return = {
221	character_set => $item[2],
222	}
223	}
224
225	reference_definition : /references/i table_name parens_field_list(?) match_type(?) on_delete_do(?) on_update_do(?)
226	{
227	$return = {
228	type => 'foreign_key',
229	reference_table => $item[2],
230	reference_fields => $item[3][0],
231	match_type => $item[4][0],
232	on_delete_do => $item[5][0],
233	on_update_do => $item[6][0],
234	}
235	}
236
237	match_type : /match full/i { 'full' }
238	\|
239	/match partial/i { 'partial' }
240
241	on_delete_do : /on delete/i reference_option
242	{ $item[2] }
243
244	on_update_do : /on update/i reference_option
245	{ $item[2] }
246
247	reference_option: /restrict/i \|
248	/cascade/i \|
249	/set null/i \|
250	/no action/i \|
251	/set default/i
252	{ $item[1] }
253
254	index : normal_index
255	\| fulltext_index
256	\| <error>
257
258	table_name : NAME
259
260	field_name : NAME
261
262	index_name : NAME
263
264	data_type : access_data_type parens_value_list(s?) type_qualifier(s?)
265	{
266	$return = {
267	type => $item[1],
268	size => $item[2][0],
269	qualifiers => $item[3],
270	}
271	}
272
273	access_data_type : /long integer/i { $return = 'Long Integer' }
274	\| /text/i { $return = 'Text' }
275	\| /datetime (\(short\))?/i { $return = 'DateTime' }
276	\| /boolean/i { $return = 'Boolean' }
277	\| WORD
278
279	parens_field_list : '(' field_name(s /,/) ')'
280	{ $item[2] }
281
282	parens_value_list : '(' VALUE(s /,/) ')'
283	{ $item[2] }
284
285	type_qualifier : /(BINARY\|UNSIGNED\|ZEROFILL)/i
286	{ lc $item[1] }
287
288	field_type : WORD
289
290	create_index : /create/i /index/i
291
292	not_null : /not/i /null/i { $return = 0 }
293
294	unsigned : /unsigned/i { $return = 0 }
295
296	default_val : /default/i /'(?:.?\\').?'\|(?:')?[\w\d:.-](?:')?/
297	{
298	$item[2] =~ s/^\s'\|'\s$//g;
299	$return = $item[2];
300	}
301
302	auto_inc : /auto_increment/i { 1 }
303
304	primary_key : /primary/i /key/i { 1 }
305
306	constraint : primary_key_def
307	\| unique_key_def
308	\| foreign_key_def
309	\| <error>
310
311	foreign_key_def : foreign_key_def_begin parens_field_list reference_definition
312	{
313	$return = {
314	supertype => 'constraint',
315	type => 'foreign_key',
316	name => $item[1],
317	fields => $item[2],
318	%{ $item{'reference_definition'} },
319	}
320	}
321
322	foreign_key_def_begin : /constraint/i /foreign key/i
323	{ $return = '' }
324	\|
325	/constraint/i WORD /foreign key/i
326	{ $return = $item[2] }
327	\|
328	/foreign key/i
329	{ $return = '' }
330
331	primary_key_def : primary_key index_name(?) '(' name_with_opt_paren(s /,/) ')'
332	{
333	$return = {
334	supertype => 'constraint',
335	name => $item{'index_name(?)'}[0],
336	type => 'primary_key',
337	fields => $item[4],
338	};
339	}
340
341	unique_key_def : UNIQUE KEY(?) index_name(?) '(' name_with_opt_paren(s /,/) ')'
342	{
343	$return = {
344	supertype => 'constraint',
345	name => $item{'index_name(?)'}[0],
346	type => 'unique',
347	fields => $item[5],
348	}
349	}
350
351	normal_index : KEY index_name(?) '(' name_with_opt_paren(s /,/) ')'
352	{
353	$return = {
354	supertype => 'index',
355	type => 'normal',
356	name => $item{'index_name(?)'}[0],
357	fields => $item[4],
358	}
359	}
360
361	fulltext_index : /fulltext/i KEY(?) index_name(?) '(' name_with_opt_paren(s /,/) ')'
362	{
363	$return = {
364	supertype => 'index',
365	type => 'fulltext',
366	name => $item{'index_name(?)'}[0],
367	fields => $item[5],
368	}
369	}
370
371	name_with_opt_paren : NAME parens_value_list(s?)
372	{ $item[2][0] ? "$item[1]($item[2][0][0])" : $item[1] }
373
374	UNIQUE : /unique/i { 1 }
375
376	KEY : /key/i \| /index/i
377
378	table_option : WORD /\s=\s/ WORD
379	{
380	$return = { $item[1] => $item[3] };
381	}
382
383	CREATE : /create/i
384
385	TEMPORARY : /temporary/i
386
387	TABLE : /table/i
388
389	WORD : /\w+/
390
391	DIGITS : /\d+/
392
393	COMMA : ','
394
395	NAME : "`" /\w+/ "`"
396	{ $item[2] }
397	\| /\w+/
398	{ $item[1] }
399
400	VALUE : /[-+]?\.?\d+(?:[eE]\d+)?/
401	{ $item[1] }
402	\| /'.*?'/
403	{
404	# remove leading/trailing quotes
405	my $val = $item[1];
406	$val =~ s/^['"]\|['"]$//g;
407	$return = $val;
408	}
409	\| /NULL/
410	{ 'NULL' }
411
412	!;
413
414	# -------------------------------------------------------------------
415	sub parse {
416	my ( $translator, $data ) = @_;
417	my $parser = Parse::RecDescent->new($GRAMMAR);
418
419	local $::RD_TRACE = $translator->trace ? 1 : undef;
420	local $DEBUG = $translator->debug;
421
422	unless (defined $parser) {
423	return $translator->error("Error instantiating Parse::RecDescent ".
424	"instance: Bad grammer");
425	}
426
427	my $result = $parser->startrule($data);
428	return $translator->error( "Parse failed." ) unless defined $result;
429	warn Dumper( $result ) if $DEBUG;
430
431	my $schema = $translator->schema;
432	my @tables = sort {
433	$result->{ $a }->{'order'} <=> $result->{ $b }->{'order'}
434	} keys %{ $result };
435
436	for my $table_name ( @tables ) {
437	my $tdata = $result->{ $table_name };
438	my $table = $schema->add_table(
439	name => $tdata->{'table_name'},
440	) or die $schema->error;
441
442	$table->comments( $tdata->{'comments'} );
443
444	my @fields = sort {
445	$tdata->{'fields'}->{$a}->{'order'}
446	<=>
447	$tdata->{'fields'}->{$b}->{'order'}
448	} keys %{ $tdata->{'fields'} };
449
450	for my $fname ( @fields ) {
451	my $fdata = $tdata->{'fields'}{ $fname };
452	my $field = $table->add_field(
453	name => $fdata->{'name'},
454	data_type => $fdata->{'data_type'},
455	size => $fdata->{'size'},
456	default_value => $fdata->{'default'},
457	is_auto_increment => $fdata->{'is_auto_inc'},
458	is_nullable => $fdata->{'null'},
459	comments => $fdata->{'comments'},
460	) or die $table->error;
461
462	$table->primary_key( $field->name ) if $fdata->{'is_primary_key'};
463
464	# for my $qual ( qw[ binary unsigned zerofill list ] ) {
465	# if ( my $val = $fdata->{ $qual } \|\| $fdata->{ uc $qual } ) {
466	# next if ref $val eq 'ARRAY' && !@$val;
467	# $field->extra( $qual, $val );
468	# }
469	# }
470
471	# for my $cdata ( @{ $fdata->{'constraints'} } ) {
472	# next unless $cdata->{'type'} eq 'foreign_key';
473	# $cdata->{'fields'} \|\|= [ $field->name ];
474	# push @{ $tdata->{'constraints'} }, $cdata;
475	# }
476	}
477
478	for my $idata ( @{ $tdata->{'indices'} \|\| [] } ) {
479	my $index = $table->add_index(
480	name => $idata->{'name'},
481	type => uc $idata->{'type'},
482	fields => $idata->{'fields'},
483	) or die $table->error;
484	}
485
486	# for my $cdata ( @{ $tdata->{'constraints'} \|\| [] } ) {
487	# my $constraint = $table->add_constraint(
488	# name => $cdata->{'name'},
489	# type => $cdata->{'type'},
490	# fields => $cdata->{'fields'},
491	# reference_table => $cdata->{'reference_table'},
492	# reference_fields => $cdata->{'reference_fields'},
493	# match_type => $cdata->{'match_type'} \|\| '',
494	# on_delete => $cdata->{'on_delete_do'},
495	# on_update => $cdata->{'on_update_do'},
496	# ) or die $table->error;
497	# }
498	}
499
500	return 1;
501	}
502
503	1;
504
505	# -------------------------------------------------------------------
506	# Where man is not nature is barren.
507	# William Blake
508	# -------------------------------------------------------------------
509
510	=pod
511
512	=head1 AUTHOR
513
514	Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
515
516	=head1 SEE ALSO
517
518	perl(1), Parse::RecDescent, SQL::Translator::Schema.
519
520	=cut