lib/SQL/Translator/Parser/SQLite.pm

   1 package SQL::Translator::Parser::SQLite;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: SQLite.pm,v 1.7 2005-06-28 16:39:41 mwz444 Exp $
   5 # -------------------------------------------------------------------
   6 # Copyright (C) 2002-4 SQLFairy Authors
   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 |
 112     delete-statement | select-statement
 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 ];
 155 $VERSION = sprintf "%d.%02d", q$Revision: 1.7 $ =~ /(\d+)\.(\d+)/;
 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 {
 173     my ( %tables, $table_order, @table_comments, @views, @triggers );
 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 #
 182 startrule : statement(s) eofile {
 183     $return      = {
 184         tables   => \%tables,
 185         views    => \@views,
 186         triggers => \@triggers,
 187     }
 188 }
 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'};
 414         push @triggers, {
 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'};
 427         push @triggers, {
 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 #
 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 #
 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
 507 VIEW : /view/i
 508
 509 SELECT : /select/i
 510
 511 ON : /on/i
 512
 513 AS : /as/i
 514
 515 WORD : /\w+/
 516
 517 WHEN : /when/i
 518
 519 UNIQUE : /unique/i { 1 }
 520
 521 SEMICOLON : ';'
 522
 523 NAME : /'?(\w+)'?/ { $return = $1 }
 524
 525 VALUE : /[-+]?\.?\d+(?:[eE]\d+)?/
 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;
 557     my @tables =
 558         map   { $_->[1] }
 559         sort  { $a->[0] <=> $b->[0] }
 560         map   { [ $result->{'tables'}{ $_ }->{'order'}, $_ ] }
 561         keys %{ $result->{'tables'} };
 562
 563     for my $table_name ( @tables ) {
 564         my $tdata =  $result->{'tables'}{ $table_name };
 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'} || '',
 607                 on_delete        => $cdata->{'on_delete'} || $cdata->{'on_delete_do'},
 608                 on_update        => $cdata->{'on_update'} || $cdata->{'on_update_do'},
 609             ) or die $table->error;
 610         }
 611     }
 612
 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
 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