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

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

=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 warnings;

our $VERSION = '1.62';

our $DEBUG;
$DEBUG   = 0 unless defined $DEBUG;

use Data::Dumper;
use SQL::Translator::Utils qw/ddl_parser_instance/;

use base qw(Exporter);
our @EXPORT_OK = qw(parse);

our $GRAMMAR = <<'END_OF_GRAMMAR';

{
    my ( %tables, $table_order, @table_comments, @views, @triggers );

    sub _err {
      my $max_lines = 5;
      my @up_to_N_lines = split (/\n/, $_[1], $max_lines + 1);
      die sprintf ("Unable to parse line %d:\n%s\n",
        $_[0],
        join "\n", (map { "'$_'" } @up_to_N_lines[0..$max_lines - 1 ]), @up_to_N_lines > $max_lines ? '...' : ()
      );
    }

}

#
# 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
    | /^\Z/ | { _err ($thisline, $text) }

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 cascade_def(?)
    {
        $return   = {
            type             => 'foreign_key',
            reference_table  => $item[2]{'reference_table'},
            reference_fields => $item[2]{'reference_fields'},
            on_delete        => $item[3][0]{'on_delete'},
            on_update        => $item[3][0]{'on_update'},
        }
    }
    |
    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],
        }
    }
    |
    FOREIGN_KEY parens_field_list REFERENCES ref_def cascade_def(?)
    {
      $return = {
        supertype        => 'constraint',
        type             => 'foreign_key',
        fields           => $item[2],
        reference_table  => $item[4]{'reference_table'},
        reference_fields => $item[4]{'reference_fields'},
        on_delete        => $item[5][0]{'on_delete'},
        on_update        => $item[5][0]{'on_update'},
      }
    }

ref_def : table_name parens_field_list
    { $return = { reference_table => $item[1]{name}, reference_fields => $item[2] } }

cascade_def : cascade_update_def cascade_delete_def(?)
    { $return = {  on_update => $item[1], on_delete => $item[2][0] } }
    |
    cascade_delete_def cascade_update_def(?)
    { $return = {  on_delete => $item[1], on_update => $item[2][0] } }

cascade_delete_def : /on\s+delete\s+(set null|set default|cascade|restrict|no action)/i
    { $return = $1}

cascade_update_def : /on\s+update\s+(set null|set default|cascade|restrict|no action)/i
    { $return = $1}

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 : /[^)]* \( [^)]+ \) [^)]*/x # parens, balanced one deep
    | /[^)]+/

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

FOREIGN_KEY : /foreign 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+/
    | DQSTRING
    | SQSTRING

DQSTRING : '"' <skip: ''> /((?:[^"]|"")+)/ '"'
    { ($return = $item[3]) =~ s/""/"/g }

SQSTRING : "'" <skip: ''> /((?:[^']|'')*)/ "'"
    { ($return = $item[3]) =~ s/''/'/g }

VALUE : /[-+]?\d*\.?\d+(?:[eE]\d+)?/
    { $item[1] }
    | SQSTRING
    | /NULL/i
    { 'NULL' }
    | /CURRENT_TIMESTAMP/i
    { 'CURRENT_TIMESTAMP' }

END_OF_GRAMMAR


sub parse {
    my ( $translator, $data ) = @_;

    # Enable warnings within the Parse::RecDescent module.
    local $::RD_ERRORS = 1 unless defined $::RD_ERRORS; # Make sure the parser dies when it encounters an error
    local $::RD_WARN   = 1 unless defined $::RD_WARN; # Enable warnings. This will warn on unused rules &c.
    local $::RD_HINT   = 1 unless defined $::RD_HINT; # Give out hints to help fix problems.

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

    my $parser = ddl_parser_instance('SQLite');

    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'},
            scope               => 'row', # SQLite only supports row triggers
        );
    }

    return 1;
}

1;

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