lib/SQL/Translator/Parser/SQLite.pm

   1 package SQL::Translator::Parser::SQLite;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: SQLite.pm,v 1.8 2006-06-07 16:08:45 schiffbruechige 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.8 $ =~ /(\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     | drop
 195     | comment
 196     | create
 197     | <error>
 198
 199 begin_transaction : /begin transaction/i SEMICOLON
 200
 201 commit : /commit/i SEMICOLON
 202
 203 drop : /drop/i TABLE <commit> table_name SEMICOLON
 204
 205 comment : /^\s*(?:#|-{2}).*\n/
 206     {
 207         my $comment =  $item[1];
 208         $comment    =~ s/^\s*(#|-{2})\s*//;
 209         $comment    =~ s/\s*$//;
 210         $return     = $comment;
 211     }
 212
 213 comment : /\/\*/ /[^\*]+/ /\*\//
 214     {
 215         my $comment = $item[2];
 216         $comment    =~ s/^\s*|\s*$//g;
 217         $return = $comment;
 218     }
 219
 220 #
 221 # Create Index
 222 #
 223 create : CREATE TEMPORARY(?) UNIQUE(?) INDEX WORD ON table_name parens_field_list conflict_clause(?) SEMICOLON
 224     {
 225         my $db_name    = $item[7]->{'db_name'} || '';
 226         my $table_name = $item[7]->{'name'};
 227
 228         my $index        =  {
 229             name         => $item[5],
 230             fields       => $item[8],
 231             on_conflict  => $item[9][0],
 232             is_temporary => $item[2][0] ? 1 : 0,
 233         };
 234
 235         my $is_unique = $item[3][0];
 236
 237         if ( $is_unique ) {
 238             $index->{'type'} = 'unique';
 239             push @{ $tables{ $table_name }{'constraints'} }, $index;
 240         }
 241         else {
 242             push @{ $tables{ $table_name }{'indices'} }, $index;
 243         }
 244     }
 245
 246 #
 247 # Create Table
 248 #
 249 create : CREATE TEMPORARY(?) TABLE table_name '(' definition(s /,/) ')' SEMICOLON
 250     {
 251         my $db_name    = $item[4]->{'db_name'} || '';
 252         my $table_name = $item[4]->{'name'};
 253
 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;
 257
 258         for my $def ( @{ $item[6] } ) {
 259             if ( $def->{'supertype'} eq 'column' ) {
 260                 push @{ $tables{ $table_name }{'fields'} }, $def;
 261             }
 262             elsif ( $def->{'supertype'} eq 'constraint' ) {
 263                 push @{ $tables{ $table_name }{'constraints'} }, $def;
 264             }
 265         }
 266     }
 267
 268 definition : constraint_def | column_def
 269
 270 column_def: NAME type(?) column_constraint(s?)
 271     {
 272         my $column = {
 273             supertype      => 'column',
 274             name           => $item[1],
 275             data_type      => $item[2][0]->{'type'},
 276             size           => $item[2][0]->{'size'},
 277             is_nullable    => 1,
 278             is_primary_key => 0,
 279             is_unique      => 0,
 280             check          => '',
 281             default        => undef,
 282             constraints    => $item[3],
 283         };
 284
 285         for my $c ( @{ $item[3] } ) {
 286             if ( $c->{'type'} eq 'not_null' ) {
 287                 $column->{'is_nullable'} = 0;
 288             }
 289             elsif ( $c->{'type'} eq 'primary_key' ) {
 290                 $column->{'is_primary_key'} = 1;
 291             }
 292             elsif ( $c->{'type'} eq 'unique' ) {
 293                 $column->{'is_unique'} = 1;
 294             }
 295             elsif ( $c->{'type'} eq 'check' ) {
 296                 $column->{'check'} = $c->{'expression'};
 297             }
 298             elsif ( $c->{'type'} eq 'default' ) {
 299                 $column->{'default'} = $c->{'value'};
 300             }
 301         }
 302
 303         $column;
 304     }
 305
 306 type : WORD parens_value_list(?)
 307     {
 308         $return = {
 309             type => $item[1],
 310             size => $item[2][0],
 311         }
 312     }
 313
 314 column_constraint : NOT_NULL conflict_clause(?)
 315     {
 316         $return = {
 317             type => 'not_null',
 318         }
 319     }
 320     |
 321     PRIMARY_KEY sort_order(?) conflict_clause(?)
 322     {
 323         $return = {
 324             type        => 'primary_key',
 325             sort_order  => $item[2][0],
 326             on_conflict => $item[2][0],
 327         }
 328     }
 329     |
 330     UNIQUE conflict_clause(?)
 331     {
 332         $return = {
 333             type        => 'unique',
 334             on_conflict => $item[2][0],
 335         }
 336     }
 337     |
 338     CHECK_C '(' expr ')' conflict_clause(?)
 339     {
 340         $return = {
 341             type        => 'check',
 342             expression  => $item[3],
 343             on_conflict => $item[5][0],
 344         }
 345     }
 346     |
 347     DEFAULT VALUE
 348     {
 349         $return   = {
 350             type  => 'default',
 351             value => $item[2],
 352         }
 353     }
 354
 355 constraint_def : PRIMARY_KEY parens_field_list conflict_clause(?)
 356     {
 357         $return         = {
 358             supertype   => 'constraint',
 359             type        => 'primary_key',
 360             fields      => $item[2],
 361             on_conflict => $item[3][0],
 362         }
 363     }
 364     |
 365     UNIQUE parens_field_list conflict_clause(?)
 366     {
 367         $return         = {
 368             supertype   => 'constraint',
 369             type        => 'unique',
 370             fields      => $item[2],
 371             on_conflict => $item[3][0],
 372         }
 373     }
 374     |
 375     CHECK_C '(' expr ')' conflict_clause(?)
 376     {
 377         $return         = {
 378             supertype   => 'constraint',
 379             type        => 'check',
 380             expression  => $item[3],
 381             on_conflict => $item[5][0],
 382         }
 383     }
 384
 385 table_name : qualified_name
 386
 387 qualified_name : NAME
 388     { $return = { name => $item[1] } }
 389
 390 qualified_name : /(\w+)\.(\w+)/
 391     { $return = { db_name => $1, name => $2 } }
 392
 393 field_name : NAME
 394
 395 conflict_clause : /on conflict/i conflict_algorigthm
 396
 397 conflict_algorigthm : /(rollback|abort|fail|ignore|replace)/i
 398
 399 parens_field_list : '(' column_list ')'
 400     { $item[2] }
 401
 402 column_list : field_name(s /,/)
 403
 404 parens_value_list : '(' VALUE(s /,/) ')'
 405     { $item[2] }
 406
 407 expr : /[^)]+/
 408
 409 sort_order : /(ASC|DESC)/i
 410
 411 #
 412 # Create Trigger
 413
 414 create : CREATE TEMPORARY(?) TRIGGER NAME before_or_after(?) database_event ON table_name trigger_action
 415     {
 416         my $table_name = $item[8]->{'name'};
 417         push @triggers, {
 418             name         => $item[4],
 419             is_temporary => $item[2][0] ? 1 : 0,
 420             when         => $item[5][0],
 421             instead_of   => 0,
 422             db_event     => $item[6],
 423             action       => $item[9],
 424         }
 425     }
 426
 427 create : CREATE TEMPORARY(?) TRIGGER NAME instead_of database_event ON view_name trigger_action
 428     {
 429         my $table_name = $item[8]->{'name'};
 430         push @triggers, {
 431             name         => $item[4],
 432             is_temporary => $item[2][0] ? 1 : 0,
 433             when         => undef,
 434             instead_of   => 1,
 435             db_event     => $item[6],
 436             action       => $item[9],
 437         }
 438     }
 439
 440 database_event : /(delete|insert|update)/i
 441
 442 database_event : /update of/i column_list
 443
 444 trigger_action : for_each(?) when(?) BEGIN_C trigger_step(s) END_C
 445     {
 446         $return = {
 447             for_each => $item[1][0],
 448             when     => $item[2][0],
 449             steps    => $item[4],
 450         }
 451     }
 452
 453 for_each : /FOR EACH ROW/i | /FOR EACH STATEMENT/i
 454
 455 when : WHEN expr { $item[2] }
 456
 457 trigger_step : /(select|delete|insert|update)/i /[^;]+/ SEMICOLON
 458     {
 459         $return = join( ' ', $item[1], $item[2] )
 460     }
 461
 462 before_or_after : /(before|after)/i { $return = lc $1 }
 463
 464 instead_of : /instead of/i
 465
 466 view_name : qualified_name
 467
 468 #
 469 # Create View
 470 #
 471 create : CREATE TEMPORARY(?) VIEW view_name AS select_statement
 472     {
 473         push @views, {
 474             name         => $item[4]->{'name'},
 475             sql          => $item[6],
 476             is_temporary => $item[2][0] ? 1 : 0,
 477         }
 478     }
 479
 480 select_statement : SELECT /[^;]+/ SEMICOLON
 481     {
 482         $return = join( ' ', $item[1], $item[2] );
 483     }
 484
 485 #
 486 # Tokens
 487 #
 488 BEGIN_C : /begin/i
 489
 490 END_C : /end/i
 491
 492 CREATE : /create/i
 493
 494 TEMPORARY : /temp(orary)?/i { 1 }
 495
 496 TABLE : /table/i
 497
 498 INDEX : /index/i
 499
 500 NOT_NULL : /not null/i
 501
 502 PRIMARY_KEY : /primary key/i
 503
 504 CHECK_C : /check/i
 505
 506 DEFAULT : /default/i
 507
 508 TRIGGER : /trigger/i
 509
 510 VIEW : /view/i
 511
 512 SELECT : /select/i
 513
 514 ON : /on/i
 515
 516 AS : /as/i
 517
 518 WORD : /\w+/
 519
 520 WHEN : /when/i
 521
 522 UNIQUE : /unique/i { 1 }
 523
 524 SEMICOLON : ';'
 525
 526 NAME : /'?(\w+)'?/ { $return = $1 }
 527
 528 VALUE : /[-+]?\.?\d+(?:[eE]\d+)?/
 529     { $item[1] }
 530     | /'.*?'/
 531     {
 532         # remove leading/trailing quotes
 533         my $val = $item[1];
 534         $val    =~ s/^['"]|['"]$//g;
 535         $return = $val;
 536     }
 537     | /NULL/
 538     { 'NULL' }
 539     | /CURRENT_TIMESTAMP/i
 540     { 'CURRENT_TIMESTAMP' }
 541
 542 !;
 543
 544 # -------------------------------------------------------------------
 545 sub parse {
 546     my ( $translator, $data ) = @_;
 547     my $parser = Parse::RecDescent->new($GRAMMAR);
 548
 549     local $::RD_TRACE  = $translator->trace ? 1 : undef;
 550     local $DEBUG       = $translator->debug;
 551
 552     unless (defined $parser) {
 553         return $translator->error("Error instantiating Parse::RecDescent ".
 554             "instance: Bad grammer");
 555     }
 556
 557     my $result = $parser->startrule($data);
 558     return $translator->error( "Parse failed." ) unless defined $result;
 559     warn Dumper( $result ) if $DEBUG;
 560
 561     my $schema = $translator->schema;
 562     my @tables =
 563         map   { $_->[1] }
 564         sort  { $a->[0] <=> $b->[0] }
 565         map   { [ $result->{'tables'}{ $_ }->{'order'}, $_ ] }
 566         keys %{ $result->{'tables'} };
 567
 568     for my $table_name ( @tables ) {
 569         my $tdata =  $result->{'tables'}{ $table_name };
 570         my $table =  $schema->add_table(
 571             name  => $tdata->{'name'},
 572         ) or die $schema->error;
 573
 574         $table->comments( $tdata->{'comments'} );
 575
 576         for my $fdata ( @{ $tdata->{'fields'} } ) {
 577             my $field = $table->add_field(
 578                 name              => $fdata->{'name'},
 579                 data_type         => $fdata->{'data_type'},
 580                 size              => $fdata->{'size'},
 581                 default_value     => $fdata->{'default'},
 582                 is_auto_increment => $fdata->{'is_auto_inc'},
 583                 is_nullable       => $fdata->{'is_nullable'},
 584                 comments          => $fdata->{'comments'},
 585             ) or die $table->error;
 586
 587             $table->primary_key( $field->name ) if $fdata->{'is_primary_key'};
 588
 589             for my $cdata ( @{ $fdata->{'constraints'} } ) {
 590                 next unless $cdata->{'type'} eq 'foreign_key';
 591                 $cdata->{'fields'} ||= [ $field->name ];
 592                 push @{ $tdata->{'constraints'} }, $cdata;
 593             }
 594         }
 595
 596         for my $idata ( @{ $tdata->{'indices'} || [] } ) {
 597             my $index  =  $table->add_index(
 598                 name   => $idata->{'name'},
 599                 type   => uc $idata->{'type'},
 600                 fields => $idata->{'fields'},
 601             ) or die $table->error;
 602         }
 603
 604         for my $cdata ( @{ $tdata->{'constraints'} || [] } ) {
 605             my $constraint       =  $table->add_constraint(
 606                 name             => $cdata->{'name'},
 607                 type             => $cdata->{'type'},
 608                 fields           => $cdata->{'fields'},
 609                 reference_table  => $cdata->{'reference_table'},
 610                 reference_fields => $cdata->{'reference_fields'},
 611                 match_type       => $cdata->{'match_type'} || '',
 612                 on_delete        => $cdata->{'on_delete'} || $cdata->{'on_delete_do'},
 613                 on_update        => $cdata->{'on_update'} || $cdata->{'on_update_do'},
 614             ) or die $table->error;
 615         }
 616     }
 617
 618     for my $def ( @{ $result->{'views'} || [] } ) {
 619         my $view = $schema->add_view(
 620             name => $def->{'name'},
 621             sql  => $def->{'sql'},
 622         );
 623     }
 624
 625     for my $def ( @{ $result->{'triggers'} || [] } ) {
 626         my $view                = $schema->add_trigger(
 627             name                => $def->{'name'},
 628             perform_action_when => $def->{'when'},
 629             database_event      => $def->{'db_event'},
 630             action              => $def->{'action'},
 631         );
 632     }
 633
 634     return 1;
 635 }
 636
 637 1;
 638
 639 # -------------------------------------------------------------------
 640 # All wholsome food is caught without a net or a trap.
 641 # William Blake
 642 # -------------------------------------------------------------------
 643
 644 =pod
 645
 646 =head1 AUTHOR
 647
 648 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
 649
 650 =head1 SEE ALSO
 651
 652 perl(1), Parse::RecDescent, SQL::Translator::Schema.
 653
 654 =cut