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

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

# -------------------------------------------------------------------
# $Id: SQLite.pm,v 1.7 2005-06-28 16:39:41 mwz444 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::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-statement

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.7 $ =~ /(\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, @views, @triggers );
}

#
# 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 { 
    $return      = {
        tables   => \%tables, 
        views    => \@views,
        triggers => \@triggers,
    }
}

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 @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 @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

#
# Create View
#
create : CREATE TEMPORARY(?) VIEW view_name AS select_statement 
    {
        push @views, {
            name         => $item[4]->{'name'},
            sql          => $item[6], 
            is_temporary => $item[2][0] ? 1 : 0,
        }
    }

select_statement : SELECT /[^;]+/ SEMICOLON
    {
        $return = join( ' ', $item[1], $item[2] );
    }

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

VIEW : /view/i

SELECT : /select/i

ON : /on/i

AS : /as/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 = 
        map   { $_->[1] }
        sort  { $a->[0] <=> $b->[0] } 
        map   { [ $result->{'tables'}{ $_ }->{'order'}, $_ ] }
        keys %{ $result->{'tables'} };

    for my $table_name ( @tables ) {
        my $tdata =  $result->{'tables'}{ $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'} || $cdata->{'on_delete_do'},
                on_update        => $cdata->{'on_update'} || $cdata->{'on_update_do'},
            ) or die $table->error;
        }
    }

    for my $def ( @{ $result->{'views'} || [] } ) {
        my $view = $schema->add_view(
            name => $def->{'name'},
            sql  => $def->{'sql'},
        );
    }

    for my $def ( @{ $result->{'triggers'} || [] } ) {
        my $view                = $schema->add_trigger(
            name                => $def->{'name'},
            perform_action_when => $def->{'when'},
            database_event      => $def->{'db_event'},
            action              => $def->{'action'},
        );
    }

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