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

package SQL::Translator::Parser::SQLite;

# -------------------------------------------------------------------
# $Id: SQLite.pm,v 1.1 2003-10-03 00:20:51 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::SQLite - parser for SQLite

=head1 SYNOPSIS

  use SQL::Translator;
  use SQL::Translator::Parser::SQLite;

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

=head1 DESCRIPTION

This is a grammar for parsing CREATE statements for SQLite as 
described here:

    http://www.sqlite.org/lang.html

CREATE INDEX

sql-statement ::=
    CREATE [TEMP | TEMPORARY] [UNIQUE] INDEX index-name 
     ON [database-name .] table-name ( column-name [, column-name]* )
     [ ON CONFLICT conflict-algorithm ]

column-name ::=
    name [ ASC | DESC ]

CREATE TABLE

sql-command ::=
    CREATE [TEMP | TEMPORARY] TABLE table-name (
        column-def [, column-def]*
        [, constraint]*
     )

sql-command ::=
    CREATE [TEMP | TEMPORARY] TABLE table-name AS select-statement

column-def ::=
    name [type] [[CONSTRAINT name] column-constraint]*

type ::=
    typename |
     typename ( number ) |
     typename ( number , number )

column-constraint ::=
    NOT NULL [ conflict-clause ] |
    PRIMARY KEY [sort-order] [ conflict-clause ] |
    UNIQUE [ conflict-clause ] |
    CHECK ( expr ) [ conflict-clause ] |
    DEFAULT value

constraint ::=
    PRIMARY KEY ( name [, name]* ) [ conflict-clause ]|
    UNIQUE ( name [, name]* ) [ conflict-clause ] |
    CHECK ( expr ) [ conflict-clause ]

conflict-clause ::=
    ON CONFLICT conflict-algorithm

CREATE TRIGGER

sql-statement ::=
    CREATE [TEMP | TEMPORARY] TRIGGER trigger-name [ BEFORE | AFTER ]
    database-event ON [database-name .] table-name
    trigger-action

sql-statement ::=
    CREATE [TEMP | TEMPORARY] TRIGGER trigger-name INSTEAD OF
    database-event ON [database-name .] view-name
    trigger-action

database-event ::=
    DELETE | 
    INSERT | 
    UPDATE | 
    UPDATE OF column-list

trigger-action ::=
    [ FOR EACH ROW | FOR EACH STATEMENT ] [ WHEN expression ] 
        BEGIN 
            trigger-step ; [ trigger-step ; ]*
        END

trigger-step ::=
    update-statement | insert-statement | 
    delete-statement | select-statemen

CREATE VIEW

sql-command ::=
    CREATE [TEMP | TEMPORARY] VIEW view-name AS select-statement

ON CONFLICT clause

    conflict-clause ::=
    ON CONFLICT conflict-algorithm

    conflict-algorithm ::=
    ROLLBACK | ABORT | FAIL | IGNORE | REPLACE

expression

expr ::=
    expr binary-op expr |
    expr like-op expr |
    unary-op expr |
    ( expr ) |
    column-name |
    table-name . column-name |
    database-name . table-name . column-name |
    literal-value |
    function-name ( expr-list | * ) |
    expr (+) |
    expr ISNULL |
    expr NOTNULL |
    expr [NOT] BETWEEN expr AND expr |
    expr [NOT] IN ( value-list ) |
    expr [NOT] IN ( select-statement ) |
    ( select-statement ) |
    CASE [expr] ( WHEN expr THEN expr )+ [ELSE expr] END

like-op::=
    LIKE | GLOB | NOT LIKE | NOT GLOB

=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 : begin_transaction
    | commit
    | comment
    | create
    | <error>

begin_transaction : /begin transaction/i SEMICOLON

commit : /commit/i SEMICOLON

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

comment : /\/\*/ /[^\*]+/ /\*\// 
    {
        my $comment = $item[2];
        $comment    =~ s/^\s*|\s*$//g;
        $return = $comment;
    }

#
# Create Index
#
create : CREATE TEMPORARY(?) UNIQUE(?) INDEX WORD ON table_name parens_field_list conflict_clause(?) SEMICOLON
    {
        my $db_name    = $item[7]->{'db_name'} || '';
        my $table_name = $item[7]->{'name'};

        my $index        =  { 
            name         => $item[5],
            fields       => $item[8],
            on_conflict  => $item[9][0],
            is_temporary => $item[2][0] ? 1 : 0,
        };

        my $is_unique = $item[3][0];

        if ( $is_unique ) {
            $index->{'type'} = 'unique';
            push @{ $tables{ $table_name }{'constraints'} }, $index;
        }
        else {
            push @{ $tables{ $table_name }{'indices'} }, $index;
        }
    }

#
# Create Table
#
create : CREATE TEMPORARY(?) TABLE table_name '(' definition(s /,/) ')' SEMICOLON
    {
        my $db_name    = $item[4]->{'db_name'} || '';
        my $table_name = $item[4]->{'name'};

        $tables{ $table_name }{'name'}         = $table_name;
        $tables{ $table_name }{'is_temporary'} = $item[2][0] ? 1 : 0;
        $tables{ $table_name }{'order'}        = ++$table_order;

        for my $def ( @{ $item[6] } ) {
            if ( $def->{'supertype'} eq 'column' ) {
                push @{ $tables{ $table_name }{'fields'} }, $def;
            }
            elsif ( $def->{'supertype'} eq 'constraint' ) {
                push @{ $tables{ $table_name }{'constraints'} }, $def;
            }
        }
    }

definition : constraint_def | column_def 

column_def: NAME type(?) column_constraint(s?)
    {
        my $column = {
            supertype      => 'column',
            name           => $item[1],  
            data_type      => $item[2][0]->{'type'},
            size           => $item[2][0]->{'size'},
            is_nullable    => 1,
            is_primary_key => 0,
            is_unique      => 0,
            check          => '',
            default        => undef,
            constraints    => $item[3],
        };

        for my $c ( @{ $item[3] } ) {
            if ( $c->{'type'} eq 'not_null' ) {
                $column->{'is_nullable'} = 0;
            }
            elsif ( $c->{'type'} eq 'primary_key' ) {
                $column->{'is_primary_key'} = 1;
            }
            elsif ( $c->{'type'} eq 'unique' ) {
                $column->{'is_unique'} = 1;
            }
            elsif ( $c->{'type'} eq 'check' ) {
                $column->{'check'} = $c->{'expression'};
            }
            elsif ( $c->{'type'} eq 'default' ) {
                $column->{'default'} = $c->{'value'};
            }
        }

        $column;
    }

type : WORD parens_value_list(?)
    {
        $return = {
            type => $item[1],
            size => $item[2][0],
        }
    }

column_constraint : NOT_NULL conflict_clause(?)
    {
        $return = {
            type => 'not_null',
        }
    }
    |
    PRIMARY_KEY sort_order(?) conflict_clause(?)
    {
        $return = {
            type        => 'primary_key',
            sort_order  => $item[2][0],
            on_conflict => $item[2][0], 
        }
    }
    |
    UNIQUE conflict_clause(?)
    {
        $return = {
            type        => 'unique',
            on_conflict => $item[2][0], 
        }
    }
    |
    CHECK_C '(' expr ')' conflict_clause(?)
    {
        $return = {
            type        => 'check',
            expression  => $item[3],
            on_conflict => $item[5][0], 
        }
    }
    |
    DEFAULT VALUE
    {
        $return   = {
            type  => 'default',
            value => $item[2],
        }
    }

constraint_def : PRIMARY_KEY parens_field_list conflict_clause(?)
    {
        $return         = {
            supertype   => 'constraint',
            type        => 'primary_key',
            fields      => $item[2],
            on_conflict => $item[3][0],
        }
    }
    |
    UNIQUE parens_field_list conflict_clause(?)
    {
        $return         = {
            supertype   => 'constraint',
            type        => 'unique',
            fields      => $item[2],
            on_conflict => $item[3][0],
        }
    }
    |
    CHECK_C '(' expr ')' conflict_clause(?)
    {
        $return         = {
            supertype   => 'constraint',
            type        => 'check',
            expression  => $item[3],
            on_conflict => $item[5][0],
        }
    }

table_name : qualified_name
    
qualified_name : NAME 
    { $return = { name => $item[1] } }

qualified_name : /(\w+)\.(\w+)/ 
    { $return = { db_name => $1, name => $2 } }

field_name : NAME

conflict_clause : /on conflict/i conflict_algorigthm

conflict_algorigthm : /(rollback|abort|fail|ignore|replace)/i

parens_field_list : '(' column_list ')'
    { $item[2] }

column_list : field_name(s /,/)

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

expr : /[^)]+/

sort_order : /(ASC|DESC)/i

#
# Create Trigger

create : CREATE TEMPORARY(?) TRIGGER NAME before_or_after(?) database_event ON table_name trigger_action
    {
        my $table_name = $item[8]->{'name'};
        push @{ $tables{ $table_name }{'triggers'} }, {
            name         => $item[4],
            is_temporary => $item[2][0] ? 1 : 0,
            when         => $item[5][0],
            instead_of   => 0,
            db_event     => $item[6],
            action       => $item[9],
        }
    }

create : CREATE TEMPORARY(?) TRIGGER NAME instead_of database_event ON view_name trigger_action
    {
        my $table_name = $item[8]->{'name'};
        push @{ $tables{ $table_name }{'triggers'} }, {
            name         => $item[4],
            is_temporary => $item[2][0] ? 1 : 0,
            when         => undef,
            instead_of   => 1,
            db_event     => $item[6],
            action       => $item[9],
        }
    }

database_event : /(delete|insert|update)/i

database_event : /update of/i column_list

trigger_action : for_each(?) when(?) BEGIN_C trigger_step(s) END_C
    {
        $return = {
            for_each => $item[1][0],
            when     => $item[2][0],
            steps    => $item[4],
        }
    }

for_each : /FOR EACH ROW/i | /FOR EACH STATEMENT/i

when : WHEN expr { $item[2] }

trigger_step : /(select|delete|insert|update)/i /[^;]+/ SEMICOLON
    {
        $return = join( ' ', $item[1], $item[2] )
    }   

before_or_after : /(before|after)/i { $return = lc $1 }

instead_of : /instead of/i

view_name : qualified_name

#
# Tokens
#
BEGIN_C : /begin/i

END_C : /end/i

CREATE : /create/i

TEMPORARY : /temp(orary)?/i { 1 }

TABLE : /table/i

INDEX : /index/i

NOT_NULL : /not null/i

PRIMARY_KEY : /primary key/i

CHECK_C : /check/i

DEFAULT : /default/i

TRIGGER : /trigger/i

ON : /on/i

WORD : /\w+/

WHEN : /when/i

UNIQUE : /unique/i { 1 }

SEMICOLON : ';'

NAME    : /'?(\w+)'?/ { $return = $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->{'name'},
        ) or die $schema->error;

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

        for my $fdata ( @{ $tdata->{'fields'} } ) {
            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->{'is_nullable'},
                comments          => $fdata->{'comments'},
            ) or die $table->error;

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

            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;

# -------------------------------------------------------------------
# All wholsome food is caught without a net or a trap.
# 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
72aa2647	1	package SQL::Translator::Parser::SQLite;
	2
	3	# -------------------------------------------------------------------
	4	# $Id: SQLite.pm,v 1.1 2003-10-03 00:20:51 kycl4rk Exp $
	5	# -------------------------------------------------------------------
	6	# Copyright (C) 2003 Ken Y. Clark <kclark@cpan.org>,
	7	# darren chamberlain <darren@cpan.org>,
	8	# Chris Mungall <cjm@fruitfly.org>
	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	# -------------------------------------------------------------------
	24
	25	=head1 NAME
	26
	27	SQL::Translator::Parser::SQLite - parser for SQLite
	28
	29	=head1 SYNOPSIS
	30
	31	use SQL::Translator;
	32	use SQL::Translator::Parser::SQLite;
	33
	34	my $translator = SQL::Translator->new;
	35	$translator->parser("SQL::Translator::Parser::SQLite");
	36
	37	=head1 DESCRIPTION
	38
	39	This is a grammar for parsing CREATE statements for SQLite as
	40	described here:
	41
	42	http://www.sqlite.org/lang.html
	43
	44	CREATE INDEX
	45
	46	sql-statement ::=
	47	CREATE [TEMP \| TEMPORARY] [UNIQUE] INDEX index-name
	48	ON [database-name .] table-name ( column-name [, column-name]* )
	49	[ ON CONFLICT conflict-algorithm ]
	50
	51	column-name ::=
	52	name [ ASC \| DESC ]
	53
	54	CREATE TABLE
	55
	56	sql-command ::=
	57	CREATE [TEMP \| TEMPORARY] TABLE table-name (
	58	column-def [, column-def]*
	59	[, constraint]*
	60	)
	61
	62	sql-command ::=
	63	CREATE [TEMP \| TEMPORARY] TABLE table-name AS select-statement
	64
65	column-def ::=
66	name [type] [[CONSTRAINT name] column-constraint]*
67
68	type ::=
69	typename \|
70	typename ( number ) \|
71	typename ( number , number )
72
73	column-constraint ::=
74	NOT NULL [ conflict-clause ] \|
75	PRIMARY KEY [sort-order] [ conflict-clause ] \|
76	UNIQUE [ conflict-clause ] \|
77	CHECK ( expr ) [ conflict-clause ] \|
78	DEFAULT value
79
80	constraint ::=
81	PRIMARY KEY ( name [, name]* ) [ conflict-clause ]\|
82	UNIQUE ( name [, name]* ) [ conflict-clause ] \|
83	CHECK ( expr ) [ conflict-clause ]
84
85	conflict-clause ::=
86	ON CONFLICT conflict-algorithm
87
88	CREATE TRIGGER
89
90	sql-statement ::=
91	CREATE [TEMP \| TEMPORARY] TRIGGER trigger-name [ BEFORE \| AFTER ]
92	database-event ON [database-name .] table-name
93	trigger-action
94
95	sql-statement ::=
96	CREATE [TEMP \| TEMPORARY] TRIGGER trigger-name INSTEAD OF
97	database-event ON [database-name .] view-name
98	trigger-action
99
100	database-event ::=
101	DELETE \|
102	INSERT \|
103	UPDATE \|
104	UPDATE OF column-list
105
106	trigger-action ::=
107	[ FOR EACH ROW \| FOR EACH STATEMENT ] [ WHEN expression ]
108	BEGIN
109	trigger-step ; [ trigger-step ; ]*
110	END
111
112	trigger-step ::=
113	update-statement \| insert-statement \|
114	delete-statement \| select-statemen
115
116	CREATE VIEW
117
118	sql-command ::=
119	CREATE [TEMP \| TEMPORARY] VIEW view-name AS select-statement
120
121	ON CONFLICT clause
122
123	conflict-clause ::=
124	ON CONFLICT conflict-algorithm
125
126	conflict-algorithm ::=
127	ROLLBACK \| ABORT \| FAIL \| IGNORE \| REPLACE
128
129	expression
130
131	expr ::=
132	expr binary-op expr \|
133	expr like-op expr \|
134	unary-op expr \|
135	( expr ) \|
136	column-name \|
137	table-name . column-name \|
138	database-name . table-name . column-name \|
139	literal-value \|
140	function-name ( expr-list \| * ) \|
141	expr (+) \|
142	expr ISNULL \|
143	expr NOTNULL \|
144	expr [NOT] BETWEEN expr AND expr \|
145	expr [NOT] IN ( value-list ) \|
146	expr [NOT] IN ( select-statement ) \|
147	( select-statement ) \|
148	CASE [expr] ( WHEN expr THEN expr )+ [ELSE expr] END
149
150	like-op::=
151	LIKE \| GLOB \| NOT LIKE \| NOT GLOB
152
153	=cut
154
155	use strict;
156	use vars qw[ $DEBUG $VERSION $GRAMMAR @EXPORT_OK ];
157	$VERSION = sprintf "%d.%02d", q$Revision: 1.1 $ =~ /(\d+)\.(\d+)/;
158	$DEBUG = 0 unless defined $DEBUG;
159
160	use Data::Dumper;
161	use Parse::RecDescent;
162	use Exporter;
163	use base qw(Exporter);
164
165	@EXPORT_OK = qw(parse);
166
167	# Enable warnings within the Parse::RecDescent module.
168	$::RD_ERRORS = 1; # Make sure the parser dies when it encounters an error
169	$::RD_WARN = 1; # Enable warnings. This will warn on unused rules &c.
170	$::RD_HINT = 1; # Give out hints to help fix problems.
171
172	$GRAMMAR = q!
173
174	{
175	my ( %tables, $table_order, @table_comments );
176	}
177
178	#
179	# The "eofile" rule makes the parser fail if any "statement" rule
180	# fails. Otherwise, the first successful match by a "statement"
181	# won't cause the failure needed to know that the parse, as a whole,
182	# failed. -ky
183	#
184	startrule : statement(s) eofile { \%tables }
185
186	eofile : /^\Z/
187
188	statement : begin_transaction
189	\| commit
190	\| comment
191	\| create
192	\| <error>
193
194	begin_transaction : /begin transaction/i SEMICOLON
195
196	commit : /commit/i SEMICOLON
197
198	comment : /^\s(?:#\|-{2}).\n/
199	{
200	my $comment = $item[1];
201	$comment =~ s/^\s(#\|-{2})\s//;
202	$comment =~ s/\s*$//;
203	$return = $comment;
204	}
205
206	comment : /\/\/ /[^\]+/ /\*\//
207	{
208	my $comment = $item[2];
209	$comment =~ s/^\s\|\s$//g;
210	$return = $comment;
211	}
212
213	#
214	# Create Index
215	#
216	create : CREATE TEMPORARY(?) UNIQUE(?) INDEX WORD ON table_name parens_field_list conflict_clause(?) SEMICOLON
217	{
218	my $db_name = $item[7]->{'db_name'} \|\| '';
219	my $table_name = $item[7]->{'name'};
220
221	my $index = {
222	name => $item[5],
223	fields => $item[8],
224	on_conflict => $item[9][0],
225	is_temporary => $item[2][0] ? 1 : 0,
226	};
227
228	my $is_unique = $item[3][0];
229
230	if ( $is_unique ) {
231	$index->{'type'} = 'unique';
232	push @{ $tables{ $table_name }{'constraints'} }, $index;
233	}
234	else {
235	push @{ $tables{ $table_name }{'indices'} }, $index;
236	}
237	}
238
239	#
240	# Create Table
241	#
242	create : CREATE TEMPORARY(?) TABLE table_name '(' definition(s /,/) ')' SEMICOLON
243	{
244	my $db_name = $item[4]->{'db_name'} \|\| '';
245	my $table_name = $item[4]->{'name'};
246
247	$tables{ $table_name }{'name'} = $table_name;
248	$tables{ $table_name }{'is_temporary'} = $item[2][0] ? 1 : 0;
249	$tables{ $table_name }{'order'} = ++$table_order;
250
251	for my $def ( @{ $item[6] } ) {
252	if ( $def->{'supertype'} eq 'column' ) {
253	push @{ $tables{ $table_name }{'fields'} }, $def;
254	}
255	elsif ( $def->{'supertype'} eq 'constraint' ) {
256	push @{ $tables{ $table_name }{'constraints'} }, $def;
257	}
258	}
259	}
260
261	definition : constraint_def \| column_def
262
263	column_def: NAME type(?) column_constraint(s?)
264	{
265	my $column = {
266	supertype => 'column',
267	name => $item[1],
268	data_type => $item[2][0]->{'type'},
269	size => $item[2][0]->{'size'},
270	is_nullable => 1,
271	is_primary_key => 0,
272	is_unique => 0,
273	check => '',
274	default => undef,
275	constraints => $item[3],
276	};
277
278	for my $c ( @{ $item[3] } ) {
279	if ( $c->{'type'} eq 'not_null' ) {
280	$column->{'is_nullable'} = 0;
281	}
282	elsif ( $c->{'type'} eq 'primary_key' ) {
283	$column->{'is_primary_key'} = 1;
284	}
285	elsif ( $c->{'type'} eq 'unique' ) {
286	$column->{'is_unique'} = 1;
287	}
288	elsif ( $c->{'type'} eq 'check' ) {
289	$column->{'check'} = $c->{'expression'};
290	}
291	elsif ( $c->{'type'} eq 'default' ) {
292	$column->{'default'} = $c->{'value'};
293	}
294	}
295
296	$column;
297	}
298
299	type : WORD parens_value_list(?)
300	{
301	$return = {
302	type => $item[1],
303	size => $item[2][0],
304	}
305	}
306
307	column_constraint : NOT_NULL conflict_clause(?)
308	{
309	$return = {
310	type => 'not_null',
311	}
312	}
313	\|
314	PRIMARY_KEY sort_order(?) conflict_clause(?)
315	{
316	$return = {
317	type => 'primary_key',
318	sort_order => $item[2][0],
319	on_conflict => $item[2][0],
320	}
321	}
322	\|
323	UNIQUE conflict_clause(?)
324	{
325	$return = {
326	type => 'unique',
327	on_conflict => $item[2][0],
328	}
329	}
330	\|
331	CHECK_C '(' expr ')' conflict_clause(?)
332	{
333	$return = {
334	type => 'check',
335	expression => $item[3],
336	on_conflict => $item[5][0],
337	}
338	}
339	\|
340	DEFAULT VALUE
341	{
342	$return = {
343	type => 'default',
344	value => $item[2],
345	}
346	}
347
348	constraint_def : PRIMARY_KEY parens_field_list conflict_clause(?)
349	{
350	$return = {
351	supertype => 'constraint',
352	type => 'primary_key',
353	fields => $item[2],
354	on_conflict => $item[3][0],
355	}
356	}
357	\|
358	UNIQUE parens_field_list conflict_clause(?)
359	{
360	$return = {
361	supertype => 'constraint',
362	type => 'unique',
363	fields => $item[2],
364	on_conflict => $item[3][0],
365	}
366	}
367	\|
368	CHECK_C '(' expr ')' conflict_clause(?)
369	{
370	$return = {
371	supertype => 'constraint',
372	type => 'check',
373	expression => $item[3],
374	on_conflict => $item[5][0],
375	}
376	}
377
378	table_name : qualified_name
379
380	qualified_name : NAME
381	{ $return = { name => $item[1] } }
382
383	qualified_name : /(\w+)\.(\w+)/
384	{ $return = { db_name => $1, name => $2 } }
385
386	field_name : NAME
387
388	conflict_clause : /on conflict/i conflict_algorigthm
389
390	conflict_algorigthm : /(rollback\|abort\|fail\|ignore\|replace)/i
391
392	parens_field_list : '(' column_list ')'
393	{ $item[2] }
394
395	column_list : field_name(s /,/)
396
397	parens_value_list : '(' VALUE(s /,/) ')'
398	{ $item[2] }
399
400	expr : /[^)]+/
401
402	sort_order : /(ASC\|DESC)/i
403
404	#
405	# Create Trigger
406
407	create : CREATE TEMPORARY(?) TRIGGER NAME before_or_after(?) database_event ON table_name trigger_action
408	{
409	my $table_name = $item[8]->{'name'};
410	push @{ $tables{ $table_name }{'triggers'} }, {
411	name => $item[4],
412	is_temporary => $item[2][0] ? 1 : 0,
413	when => $item[5][0],
414	instead_of => 0,
415	db_event => $item[6],
416	action => $item[9],
417	}
418	}
419
420	create : CREATE TEMPORARY(?) TRIGGER NAME instead_of database_event ON view_name trigger_action
421	{
422	my $table_name = $item[8]->{'name'};
423	push @{ $tables{ $table_name }{'triggers'} }, {
424	name => $item[4],
425	is_temporary => $item[2][0] ? 1 : 0,
426	when => undef,
427	instead_of => 1,
428	db_event => $item[6],
429	action => $item[9],
430	}
431	}
432
433	database_event : /(delete\|insert\|update)/i
434
435	database_event : /update of/i column_list
436
437	trigger_action : for_each(?) when(?) BEGIN_C trigger_step(s) END_C
438	{
439	$return = {
440	for_each => $item[1][0],
441	when => $item[2][0],
442	steps => $item[4],
443	}
444	}
445
446	for_each : /FOR EACH ROW/i \| /FOR EACH STATEMENT/i
447
448	when : WHEN expr { $item[2] }
449
450	trigger_step : /(select\|delete\|insert\|update)/i /[^;]+/ SEMICOLON
451	{
452	$return = join( ' ', $item[1], $item[2] )
453	}
454
455	before_or_after : /(before\|after)/i { $return = lc $1 }
456
457	instead_of : /instead of/i
458
459	view_name : qualified_name
460
461	#
462	# Tokens
463	#
464	BEGIN_C : /begin/i
465
466	END_C : /end/i
467
468	CREATE : /create/i
469
470	TEMPORARY : /temp(orary)?/i { 1 }
471
472	TABLE : /table/i
473
474	INDEX : /index/i
475
476	NOT_NULL : /not null/i
477
478	PRIMARY_KEY : /primary key/i
479
480	CHECK_C : /check/i
481
482	DEFAULT : /default/i
483
484	TRIGGER : /trigger/i
485
486	ON : /on/i
487
488	WORD : /\w+/
489
490	WHEN : /when/i
491
492	UNIQUE : /unique/i { 1 }
493
494	SEMICOLON : ';'
495
496	NAME : /'?(\w+)'?/ { $return = $1 }
497
498	VALUE : /[-+]?\.?\d+(?:[eE]\d+)?/
499	{ $item[1] }
500	\| /'.*?'/
501	{
502	# remove leading/trailing quotes
503	my $val = $item[1];
504	$val =~ s/^['"]\|['"]$//g;
505	$return = $val;
506	}
507	\| /NULL/
508	{ 'NULL' }
509
510	!;
511
512	# -------------------------------------------------------------------
513	sub parse {
514	my ( $translator, $data ) = @_;
515	my $parser = Parse::RecDescent->new($GRAMMAR);
516
517	local $::RD_TRACE = $translator->trace ? 1 : undef;
518	local $DEBUG = $translator->debug;
519
520	unless (defined $parser) {
521	return $translator->error("Error instantiating Parse::RecDescent ".
522	"instance: Bad grammer");
523	}
524
525	my $result = $parser->startrule($data);
526	return $translator->error( "Parse failed." ) unless defined $result;
527	warn Dumper( $result ) if $DEBUG;
528
529	my $schema = $translator->schema;
530	my @tables = sort {
531	$result->{ $a }->{'order'} <=> $result->{ $b }->{'order'}
532	} keys %{ $result };
533
534	for my $table_name ( @tables ) {
535	my $tdata = $result->{ $table_name };
536	my $table = $schema->add_table(
537	name => $tdata->{'name'},
538	) or die $schema->error;
539
540	$table->comments( $tdata->{'comments'} );
541
542	for my $fdata ( @{ $tdata->{'fields'} } ) {
543	my $field = $table->add_field(
544	name => $fdata->{'name'},
545	data_type => $fdata->{'data_type'},
546	size => $fdata->{'size'},
547	default_value => $fdata->{'default'},
548	is_auto_increment => $fdata->{'is_auto_inc'},
549	is_nullable => $fdata->{'is_nullable'},
550	comments => $fdata->{'comments'},
551	) or die $table->error;
552
553	$table->primary_key( $field->name ) if $fdata->{'is_primary_key'};
554
555	for my $cdata ( @{ $fdata->{'constraints'} } ) {
556	next unless $cdata->{'type'} eq 'foreign_key';
557	$cdata->{'fields'} \|\|= [ $field->name ];
558	push @{ $tdata->{'constraints'} }, $cdata;
559	}
560	}
561
562	for my $idata ( @{ $tdata->{'indices'} \|\| [] } ) {
563	my $index = $table->add_index(
564	name => $idata->{'name'},
565	type => uc $idata->{'type'},
566	fields => $idata->{'fields'},
567	) or die $table->error;
568	}
569
570	for my $cdata ( @{ $tdata->{'constraints'} \|\| [] } ) {
571	my $constraint = $table->add_constraint(
572	name => $cdata->{'name'},
573	type => $cdata->{'type'},
574	fields => $cdata->{'fields'},
575	reference_table => $cdata->{'reference_table'},
576	reference_fields => $cdata->{'reference_fields'},
577	match_type => $cdata->{'match_type'} \|\| '',
578	on_delete => $cdata->{'on_delete_do'},
579	on_update => $cdata->{'on_update_do'},
580	) or die $table->error;
581	}
582	}
583
584	return 1;
585	}
586
587	1;
588
589	# -------------------------------------------------------------------
590	# All wholsome food is caught without a net or a trap.
591	# William Blake
592	# -------------------------------------------------------------------
593
594	=pod
595
596	=head1 AUTHOR
597
598	Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
599
600	=head1 SEE ALSO
601
602	perl(1), Parse::RecDescent, SQL::Translator::Schema.
603
604	=cut