1 package SQL::Translator::Parser::SQLite;
3 # -------------------------------------------------------------------
4 # $Id: SQLite.pm,v 1.12 2006-11-10 21:43:15 mwz444 Exp $
5 # -------------------------------------------------------------------
6 # Copyright (C) 2002-4 SQLFairy Authors
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.
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.
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
21 # -------------------------------------------------------------------
25 SQL::Translator::Parser::SQLite - parser for SQLite
30 use SQL::Translator::Parser::SQLite;
32 my $translator = SQL::Translator->new;
33 $translator->parser("SQL::Translator::Parser::SQLite");
37 This is a grammar for parsing CREATE statements for SQLite as
40 http://www.sqlite.org/lang.html
45 CREATE [TEMP | TEMPORARY] [UNIQUE] INDEX index-name
46 ON [database-name .] table-name ( column-name [, column-name]* )
47 [ ON CONFLICT conflict-algorithm ]
55 CREATE [TEMP | TEMPORARY] TABLE table-name (
56 column-def [, column-def]*
61 CREATE [TEMP | TEMPORARY] TABLE table-name AS select-statement
64 name [type] [[CONSTRAINT name] column-constraint]*
69 typename ( number , number )
72 NOT NULL [ conflict-clause ] |
73 PRIMARY KEY [sort-order] [ conflict-clause ] |
74 UNIQUE [ conflict-clause ] |
75 CHECK ( expr ) [ conflict-clause ] |
79 PRIMARY KEY ( name [, name]* ) [ conflict-clause ]|
80 UNIQUE ( name [, name]* ) [ conflict-clause ] |
81 CHECK ( expr ) [ conflict-clause ]
84 ON CONFLICT conflict-algorithm
89 CREATE [TEMP | TEMPORARY] TRIGGER trigger-name [ BEFORE | AFTER ]
90 database-event ON [database-name .] table-name
94 CREATE [TEMP | TEMPORARY] TRIGGER trigger-name INSTEAD OF
95 database-event ON [database-name .] view-name
102 UPDATE OF column-list
105 [ FOR EACH ROW | FOR EACH STATEMENT ] [ WHEN expression ]
107 trigger-step ; [ trigger-step ; ]*
111 update-statement | insert-statement |
112 delete-statement | select-statement
117 CREATE [TEMP | TEMPORARY] VIEW view-name AS select-statement
122 ON CONFLICT conflict-algorithm
124 conflict-algorithm ::=
125 ROLLBACK | ABORT | FAIL | IGNORE | REPLACE
130 expr binary-op expr |
135 table-name . column-name |
136 database-name . table-name . column-name |
138 function-name ( expr-list | * ) |
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
149 LIKE | GLOB | NOT LIKE | NOT GLOB
154 use vars qw[ $DEBUG $VERSION $GRAMMAR @EXPORT_OK ];
155 $VERSION = sprintf "%d.%02d", q$Revision: 1.12 $ =~ /(\d+)\.(\d+)/;
156 $DEBUG = 0 unless defined $DEBUG;
159 use Parse::RecDescent;
161 use base qw(Exporter);
163 @EXPORT_OK = qw(parse);
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.
173 my ( %tables, $table_order, @table_comments, @views, @triggers );
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,
182 startrule : statement(s) eofile {
186 triggers => \@triggers,
192 statement : begin_transaction
199 begin_transaction : /begin transaction/i SEMICOLON
201 commit : /commit/i SEMICOLON
203 drop : /drop/i TABLE <commit> table_name SEMICOLON
205 comment : /^\s*(?:#|-{2}).*\n/
207 my $comment = $item[1];
208 $comment =~ s/^\s*(#|-{2})\s*//;
209 $comment =~ s/\s*$//;
213 comment : /\/\*/ /[^\*]+/ /\*\//
215 my $comment = $item[2];
216 $comment =~ s/^\s*|\s*$//g;
223 create : CREATE TEMPORARY(?) UNIQUE(?) INDEX WORD ON table_name parens_field_list conflict_clause(?) SEMICOLON
225 my $db_name = $item[7]->{'db_name'} || '';
226 my $table_name = $item[7]->{'name'};
231 on_conflict => $item[9][0],
232 is_temporary => $item[2][0] ? 1 : 0,
235 my $is_unique = $item[3][0];
238 $index->{'type'} = 'unique';
239 push @{ $tables{ $table_name }{'constraints'} }, $index;
242 push @{ $tables{ $table_name }{'indices'} }, $index;
249 create : CREATE TEMPORARY(?) TABLE table_name '(' definition(s /,/) ')' SEMICOLON
251 my $db_name = $item[4]->{'db_name'} || '';
252 my $table_name = $item[4]->{'name'};
254 $tables{ $table_name }{'name'} = $table_name;
255 $tables{ $table_name }{'is_temporary'} = $item[2][0] ? 1 : 0;
256 $tables{ $table_name }{'order'} = ++$table_order;
258 for my $def ( @{ $item[6] } ) {
259 if ( $def->{'supertype'} eq 'column' ) {
260 push @{ $tables{ $table_name }{'fields'} }, $def;
262 elsif ( $def->{'supertype'} eq 'constraint' ) {
263 push @{ $tables{ $table_name }{'constraints'} }, $def;
268 definition : constraint_def | column_def
270 column_def: NAME type(?) column_constraint(s?)
273 supertype => 'column',
275 data_type => $item[2][0]->{'type'},
276 size => $item[2][0]->{'size'},
282 constraints => $item[3],
285 for my $c ( @{ $item[3] } ) {
286 if ( $c->{'type'} eq 'not_null' ) {
287 $column->{'is_nullable'} = 0;
289 elsif ( $c->{'type'} eq 'primary_key' ) {
290 $column->{'is_primary_key'} = 1;
292 elsif ( $c->{'type'} eq 'unique' ) {
293 $column->{'is_unique'} = 1;
295 elsif ( $c->{'type'} eq 'check' ) {
296 $column->{'check'} = $c->{'expression'};
298 elsif ( $c->{'type'} eq 'default' ) {
299 $column->{'default'} = $c->{'value'};
306 type : WORD parens_value_list(?)
314 column_constraint : NOT_NULL conflict_clause(?)
321 PRIMARY_KEY sort_order(?) conflict_clause(?)
324 type => 'primary_key',
325 sort_order => $item[2][0],
326 on_conflict => $item[2][0],
330 UNIQUE conflict_clause(?)
334 on_conflict => $item[2][0],
338 CHECK_C '(' expr ')' conflict_clause(?)
342 expression => $item[3],
343 on_conflict => $item[5][0],
355 constraint_def : PRIMARY_KEY parens_field_list conflict_clause(?)
358 supertype => 'constraint',
359 type => 'primary_key',
361 on_conflict => $item[3][0],
365 UNIQUE parens_field_list conflict_clause(?)
368 supertype => 'constraint',
371 on_conflict => $item[3][0],
375 CHECK_C '(' expr ')' conflict_clause(?)
378 supertype => 'constraint',
380 expression => $item[3],
381 on_conflict => $item[5][0],
385 table_name : qualified_name
387 qualified_name : NAME
388 { $return = { name => $item[1] } }
390 qualified_name : /(\w+)\.(\w+)/
391 { $return = { db_name => $1, name => $2 } }
395 conflict_clause : /on conflict/i conflict_algorigthm
397 conflict_algorigthm : /(rollback|abort|fail|ignore|replace)/i
399 parens_field_list : '(' column_list ')'
402 column_list : field_name(s /,/)
404 parens_value_list : '(' VALUE(s /,/) ')'
409 sort_order : /(ASC|DESC)/i
414 create : CREATE TEMPORARY(?) TRIGGER NAME before_or_after(?) database_event ON table_name trigger_action SEMICOLON
416 my $table_name = $item[8]->{'name'};
419 is_temporary => $item[2][0] ? 1 : 0,
422 db_event => $item[6],
424 on_table => $table_name,
428 create : CREATE TEMPORARY(?) TRIGGER NAME instead_of database_event ON view_name trigger_action
430 my $table_name = $item[8]->{'name'};
433 is_temporary => $item[2][0] ? 1 : 0,
436 db_event => $item[6],
438 on_table => $table_name,
442 database_event : /(delete|insert|update)/i
444 database_event : /update of/i column_list
446 trigger_action : for_each(?) when(?) BEGIN_C trigger_step(s) END_C
449 for_each => $item[1][0],
455 for_each : /FOR EACH ROW/i | /FOR EACH STATEMENT/i
457 when : WHEN expr { $item[2] }
460 /'(\\.|''|[^\\\'])*'/
462 nonstring : /[^;\'"]+/
464 statement_body : (string | nonstring)(s?)
466 trigger_step : /(select|delete|insert|update)/i statement_body SEMICOLON
468 $return = join( ' ', $item[1], join ' ', @{ $item[2] || [] } )
471 before_or_after : /(before|after)/i { $return = lc $1 }
473 instead_of : /instead of/i
475 view_name : qualified_name
480 create : CREATE TEMPORARY(?) VIEW view_name AS select_statement
483 name => $item[4]->{'name'},
485 is_temporary => $item[2][0] ? 1 : 0,
489 select_statement : SELECT /[^;]+/ SEMICOLON
491 $return = join( ' ', $item[1], $item[2] );
503 TEMPORARY : /temp(orary)?/i { 1 }
509 NOT_NULL : /not null/i
511 PRIMARY_KEY : /primary key/i
531 UNIQUE : /unique/i { 1 }
535 NAME : /'?(\w+)'?/ { $return = $1 }
537 VALUE : /[-+]?\.?\d+(?:[eE]\d+)?/
541 # remove leading/trailing quotes
543 $val =~ s/^['"]|['"]$//g;
548 | /CURRENT_TIMESTAMP/i
549 { 'CURRENT_TIMESTAMP' }
553 # -------------------------------------------------------------------
555 my ( $translator, $data ) = @_;
556 my $parser = Parse::RecDescent->new($GRAMMAR);
558 local $::RD_TRACE = $translator->trace ? 1 : undef;
559 local $DEBUG = $translator->debug;
561 unless (defined $parser) {
562 return $translator->error("Error instantiating Parse::RecDescent ".
563 "instance: Bad grammer");
566 my $result = $parser->startrule($data);
567 return $translator->error( "Parse failed." ) unless defined $result;
568 warn Dumper( $result ) if $DEBUG;
570 my $schema = $translator->schema;
573 sort { $a->[0] <=> $b->[0] }
574 map { [ $result->{'tables'}{ $_ }->{'order'}, $_ ] }
575 keys %{ $result->{'tables'} };
577 for my $table_name ( @tables ) {
578 my $tdata = $result->{'tables'}{ $table_name };
579 my $table = $schema->add_table(
580 name => $tdata->{'name'},
581 ) or die $schema->error;
583 $table->comments( $tdata->{'comments'} );
585 for my $fdata ( @{ $tdata->{'fields'} } ) {
586 my $field = $table->add_field(
587 name => $fdata->{'name'},
588 data_type => $fdata->{'data_type'},
589 size => $fdata->{'size'},
590 default_value => $fdata->{'default'},
591 is_auto_increment => $fdata->{'is_auto_inc'},
592 is_nullable => $fdata->{'is_nullable'},
593 comments => $fdata->{'comments'},
594 ) or die $table->error;
596 $table->primary_key( $field->name ) if $fdata->{'is_primary_key'};
598 for my $cdata ( @{ $fdata->{'constraints'} } ) {
599 next unless $cdata->{'type'} eq 'foreign_key';
600 $cdata->{'fields'} ||= [ $field->name ];
601 push @{ $tdata->{'constraints'} }, $cdata;
605 for my $idata ( @{ $tdata->{'indices'} || [] } ) {
606 my $index = $table->add_index(
607 name => $idata->{'name'},
608 type => uc $idata->{'type'},
609 fields => $idata->{'fields'},
610 ) or die $table->error;
613 for my $cdata ( @{ $tdata->{'constraints'} || [] } ) {
614 my $constraint = $table->add_constraint(
615 name => $cdata->{'name'},
616 type => $cdata->{'type'},
617 fields => $cdata->{'fields'},
618 reference_table => $cdata->{'reference_table'},
619 reference_fields => $cdata->{'reference_fields'},
620 match_type => $cdata->{'match_type'} || '',
621 on_delete => $cdata->{'on_delete'} || $cdata->{'on_delete_do'},
622 on_update => $cdata->{'on_update'} || $cdata->{'on_update_do'},
623 ) or die $table->error;
627 for my $def ( @{ $result->{'views'} || [] } ) {
628 my $view = $schema->add_view(
629 name => $def->{'name'},
630 sql => $def->{'sql'},
634 for my $def ( @{ $result->{'triggers'} || [] } ) {
635 my $view = $schema->add_trigger(
636 name => $def->{'name'},
637 perform_action_when => $def->{'when'},
638 database_event => $def->{'db_event'},
639 action => $def->{'action'},
640 on_table => $def->{'on_table'},
649 # -------------------------------------------------------------------
650 # All wholsome food is caught without a net or a trap.
652 # -------------------------------------------------------------------
658 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
662 perl(1), Parse::RecDescent, SQL::Translator::Schema.