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

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

# -------------------------------------------------------------------
# Copyright (C) 2002-2009 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 = '1.59';
$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
    | drop
    | comment
    | create
    | <error>

begin_transaction : /begin/i TRANSACTION(?) SEMICOLON

commit : /commit/i SEMICOLON

drop : /drop/i (tbl_drop | view_drop | trg_drop) SEMICOLON

tbl_drop: TABLE <commit> table_name

view_drop: VIEW if_exists(?) view_name

trg_drop: TRIGGER if_exists(?) trigger_name

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 NAME 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: comment(s?) NAME type(?) column_constraint_def(s?)
    {
        my $column = {
            supertype      => 'column',
            name           => $item[2],
            data_type      => $item[3][0]->{'type'},
            size           => $item[3][0]->{'size'},
            is_nullable    => 1,
            is_primary_key => 0,
            is_unique      => 0,
            check          => '',
            default        => undef,
            constraints    => $item[4],
            comments       => $item[1],
        };


        for my $c ( @{ $item[4] } ) {
            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'};
            }
            elsif ( $c->{'type'} eq 'autoincrement' ) {
                $column->{'is_auto_inc'} = 1;
            }
        }

        $column;
    }

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

column_constraint_def : CONSTRAINT constraint_name column_constraint
    {
        $return = {
            name => $item[2],
            %{ $item[3] },
        }
    }
    |
    column_constraint

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],
        }
    }
    |
    REFERENCES ref_def
    {
        $return   = {
            type             => 'foreign_key',
            reference_table  => $item[2]{'reference_table'},
            reference_fields => $item[2]{'reference_fields'},
        }
    }
    |
    AUTOINCREMENT
    {
        $return = {
            type => 'autoincrement',
        }
    }

constraint_def : comment(s?) CONSTRAINT constraint_name table_constraint
    {
        $return = {
            comments => $item[1],
            name => $item[3],
            %{ $item[4] },
        }
    }
    |
    comment(s?) table_constraint
    {
        $return = {
            comments => $item[1],
            %{ $item[2] },
        }
    }

table_constraint : 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],
        }
    }

ref_def : /(\w+)\s*\((\w+)\)/
    { $return = { reference_table => $1, reference_fields => $2 } }

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

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

field_name : NAME

constraint_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 SEMICOLON
    {
        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_events    => [ $item[6] ],
            action       => $item[9],
            on_table     => $table_name,
        }
    }

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_events    => [ $item[6] ],
            action       => $item[9],
            on_table     => $table_name,
        }
    }

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

when : WHEN expr { $item[2] }

string :
   /'(\\.|''|[^\\\'])*'/ 

nonstring : /[^;\'"]+/

statement_body : string | nonstring

trigger_step : /(select|delete|insert|update)/i statement_body(s?) SEMICOLON
    {
        $return = join( ' ', $item[1], join ' ', @{ $item[2] || [] } )
    }   

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

instead_of : /instead of/i

if_exists : /if exists/i

view_name : qualified_name

trigger_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

TRANSACTION: /transaction/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

REFERENCES : /references/i

CONSTRAINT : /constraint/i

AUTOINCREMENT : /autoincrement/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' }
    | /CURRENT_TIMESTAMP/i
    { 'CURRENT_TIMESTAMP' }

!;

# -------------------------------------------------------------------
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_events     => $def->{'db_events'},
            action              => $def->{'action'},
            on_table            => $def->{'on_table'},
        );
    }

    return 1;
}

1;

# -------------------------------------------------------------------
# All wholsome food is caught without a net or a trap.
# William Blake
# -------------------------------------------------------------------

=pod

=head1 AUTHOR

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