lib/SQL/Translator/Parser/SQLite.pm

   1 package SQL::Translator::Parser::SQLite;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: SQLite.pm,v 1.1 2003-10-03 00:20:51 kycl4rk Exp $
   5 # -------------------------------------------------------------------
   6 # Copyright (C) 2003 Ken Y. Clark <kclark@cpan.org>,
   7 #                    darren chamberlain <darren@cpan.org>,
   8 #                    Chris Mungall <cjm@fruitfly.org>
   9 #
  10 # This program is free software; you can redistribute it and/or
  11 # modify it under the terms of the GNU General Public License as
  12 # published by the Free Software Foundation; version 2.
  13 #
  14 # This program is distributed in the hope that it will be useful, but
  15 # WITHOUT ANY WARRANTY; without even the implied warranty of
  16 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  17 # General Public License for more details.
  18 #
  19 # You should have received a copy of the GNU General Public License
  20 # along with this program; if not, write to the Free Software
  21 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
  22 # 02111-1307  USA
  23 # -------------------------------------------------------------------
  24
  25 =head1 NAME
  26
  27 SQL::Translator::Parser::SQLite - parser for SQLite
  28
  29 =head1 SYNOPSIS
  30
  31   use SQL::Translator;
  32   use SQL::Translator::Parser::SQLite;
  33
  34   my $translator = SQL::Translator->new;
  35   $translator->parser("SQL::Translator::Parser::SQLite");
  36
  37 =head1 DESCRIPTION
  38
  39 This is a grammar for parsing CREATE statements for SQLite as
  40 described here:
  41
  42     http://www.sqlite.org/lang.html
  43
  44 CREATE INDEX
  45
  46 sql-statement ::=
  47     CREATE [TEMP | TEMPORARY] [UNIQUE] INDEX index-name
  48      ON [database-name .] table-name ( column-name [, column-name]* )
  49      [ ON CONFLICT conflict-algorithm ]
  50
  51 column-name ::=
  52     name [ ASC | DESC ]
  53
  54 CREATE TABLE
  55
  56 sql-command ::=
  57     CREATE [TEMP | TEMPORARY] TABLE table-name (
  58         column-def [, column-def]*
  59         [, constraint]*
  60      )
  61
  62 sql-command ::=
  63     CREATE [TEMP | TEMPORARY] TABLE table-name AS select-statement
  64
  65 column-def ::=
  66     name [type] [[CONSTRAINT name] column-constraint]*
  67
  68 type ::=
  69     typename |
  70      typename ( number ) |
  71      typename ( number , number )
  72
  73 column-constraint ::=
  74     NOT NULL [ conflict-clause ] |
  75     PRIMARY KEY [sort-order] [ conflict-clause ] |
  76     UNIQUE [ conflict-clause ] |
  77     CHECK ( expr ) [ conflict-clause ] |
  78     DEFAULT value
  79
  80 constraint ::=
  81     PRIMARY KEY ( name [, name]* ) [ conflict-clause ]|
  82     UNIQUE ( name [, name]* ) [ conflict-clause ] |
  83     CHECK ( expr ) [ conflict-clause ]
  84
  85 conflict-clause ::=
  86     ON CONFLICT conflict-algorithm
  87
  88 CREATE TRIGGER
  89
  90 sql-statement ::=
  91     CREATE [TEMP | TEMPORARY] TRIGGER trigger-name [ BEFORE | AFTER ]
  92     database-event ON [database-name .] table-name
  93     trigger-action
  94
  95 sql-statement ::=
  96     CREATE [TEMP | TEMPORARY] TRIGGER trigger-name INSTEAD OF
  97     database-event ON [database-name .] view-name
  98     trigger-action
  99
 100 database-event ::=
 101     DELETE |
 102     INSERT |
 103     UPDATE |
 104     UPDATE OF column-list
 105
 106 trigger-action ::=
 107     [ FOR EACH ROW | FOR EACH STATEMENT ] [ WHEN expression ]
 108         BEGIN
 109             trigger-step ; [ trigger-step ; ]*
 110         END
 111
 112 trigger-step ::=
 113     update-statement | insert-statement |
 114     delete-statement | select-statemen
 115
 116 CREATE VIEW
 117
 118 sql-command ::=
 119     CREATE [TEMP | TEMPORARY] VIEW view-name AS select-statement
 120
 121 ON CONFLICT clause
 122
 123     conflict-clause ::=
 124     ON CONFLICT conflict-algorithm
 125
 126     conflict-algorithm ::=
 127     ROLLBACK | ABORT | FAIL | IGNORE | REPLACE
 128
 129 expression
 130
 131 expr ::=
 132     expr binary-op expr |
 133     expr like-op expr |
 134     unary-op expr |
 135     ( expr ) |
 136     column-name |
 137     table-name . column-name |
 138     database-name . table-name . column-name |
 139     literal-value |
 140     function-name ( expr-list | * ) |
 141     expr (+) |
 142     expr ISNULL |
 143     expr NOTNULL |
 144     expr [NOT] BETWEEN expr AND expr |
 145     expr [NOT] IN ( value-list ) |
 146     expr [NOT] IN ( select-statement ) |
 147     ( select-statement ) |
 148     CASE [expr] ( WHEN expr THEN expr )+ [ELSE expr] END
 149
 150 like-op::=
 151     LIKE | GLOB | NOT LIKE | NOT GLOB
 152
 153 =cut
 154
 155 use strict;
 156 use vars qw[ $DEBUG $VERSION $GRAMMAR @EXPORT_OK ];
 157 $VERSION = sprintf "%d.%02d", q$Revision: 1.1 $ =~ /(\d+)\.(\d+)/;
 158 $DEBUG   = 0 unless defined $DEBUG;
 159
 160 use Data::Dumper;
 161 use Parse::RecDescent;
 162 use Exporter;
 163 use base qw(Exporter);
 164
 165 @EXPORT_OK = qw(parse);
 166
 167 # Enable warnings within the Parse::RecDescent module.
 168 $::RD_ERRORS = 1; # Make sure the parser dies when it encounters an error
 169 $::RD_WARN   = 1; # Enable warnings. This will warn on unused rules &c.
 170 $::RD_HINT   = 1; # Give out hints to help fix problems.
 171
 172 $GRAMMAR = q!
 173
 174 {
 175     my ( %tables, $table_order, @table_comments );
 176 }
 177
 178 #
 179 # The "eofile" rule makes the parser fail if any "statement" rule
 180 # fails.  Otherwise, the first successful match by a "statement"
 181 # won't cause the failure needed to know that the parse, as a whole,
 182 # failed. -ky
 183 #
 184 startrule : statement(s) eofile { \%tables }
 185
 186 eofile : /^\Z/
 187
 188 statement : begin_transaction
 189     | commit
 190     | comment
 191     | create
 192     | <error>
 193
 194 begin_transaction : /begin transaction/i SEMICOLON
 195
 196 commit : /commit/i SEMICOLON
 197
 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
 206 comment : /\/\*/ /[^\*]+/ /\*\//
 207     {
 208         my $comment = $item[2];
 209         $comment    =~ s/^\s*|\s*$//g;
 210         $return = $comment;
 211     }
 212
 213 #
 214 # Create Index
 215 #
 216 create : CREATE TEMPORARY(?) UNIQUE(?) INDEX WORD ON table_name parens_field_list conflict_clause(?) SEMICOLON
 217     {
 218         my $db_name    = $item[7]->{'db_name'} || '';
 219         my $table_name = $item[7]->{'name'};
 220
 221         my $index        =  {
 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
 261 definition : constraint_def | column_def
 262
 263 column_def: NAME type(?) column_constraint(s?)
 264     {
 265         my $column = {
 266             supertype      => 'column',
 267             name           => $item[1],
 268             data_type      => $item[2][0]->{'type'},
 269             size           => $item[2][0]->{'size'},
 270             is_nullable    => 1,
 271             is_primary_key => 0,
 272             is_unique      => 0,
 273             check          => '',
 274             default        => undef,
 275             constraints    => $item[3],
 276         };
 277
 278         for my $c ( @{ $item[3] } ) {
 279             if ( $c->{'type'} eq 'not_null' ) {
 280                 $column->{'is_nullable'} = 0;
 281             }
 282             elsif ( $c->{'type'} eq 'primary_key' ) {
 283                 $column->{'is_primary_key'} = 1;
 284             }
 285             elsif ( $c->{'type'} eq 'unique' ) {
 286                 $column->{'is_unique'} = 1;
 287             }
 288             elsif ( $c->{'type'} eq 'check' ) {
 289                 $column->{'check'} = $c->{'expression'};
 290             }
 291             elsif ( $c->{'type'} eq 'default' ) {
 292                 $column->{'default'} = $c->{'value'};
 293             }
 294         }
 295
 296         $column;
 297     }
 298
 299 type : WORD parens_value_list(?)
 300     {
 301         $return = {
 302             type => $item[1],
 303             size => $item[2][0],
 304         }
 305     }
 306
 307 column_constraint : NOT_NULL conflict_clause(?)
 308     {
 309         $return = {
 310             type => 'not_null',
 311         }
 312     }
 313     |
 314     PRIMARY_KEY sort_order(?) conflict_clause(?)
 315     {
 316         $return = {
 317             type        => 'primary_key',
 318             sort_order  => $item[2][0],
 319             on_conflict => $item[2][0],
 320         }
 321     }
 322     |
 323     UNIQUE conflict_clause(?)
 324     {
 325         $return = {
 326             type        => 'unique',
 327             on_conflict => $item[2][0],
 328         }
 329     }
 330     |
 331     CHECK_C '(' expr ')' conflict_clause(?)
 332     {
 333         $return = {
 334             type        => 'check',
 335             expression  => $item[3],
 336             on_conflict => $item[5][0],
 337         }
 338     }
 339     |
 340     DEFAULT VALUE
 341     {
 342         $return   = {
 343             type  => 'default',
 344             value => $item[2],
 345         }
 346     }
 347
 348 constraint_def : PRIMARY_KEY parens_field_list conflict_clause(?)
 349     {
 350         $return         = {
 351             supertype   => 'constraint',
 352             type        => 'primary_key',
 353             fields      => $item[2],
 354             on_conflict => $item[3][0],
 355         }
 356     }
 357     |
 358     UNIQUE parens_field_list conflict_clause(?)
 359     {
 360         $return         = {
 361             supertype   => 'constraint',
 362             type        => 'unique',
 363             fields      => $item[2],
 364             on_conflict => $item[3][0],
 365         }
 366     }
 367     |
 368     CHECK_C '(' expr ')' conflict_clause(?)
 369     {
 370         $return         = {
 371             supertype   => 'constraint',
 372             type        => 'check',
 373             expression  => $item[3],
 374             on_conflict => $item[5][0],
 375         }
 376     }
 377
 378 table_name : qualified_name
 379
 380 qualified_name : NAME
 381     { $return = { name => $item[1] } }
 382
 383 qualified_name : /(\w+)\.(\w+)/
 384     { $return = { db_name => $1, name => $2 } }
 385
 386 field_name : NAME
 387
 388 conflict_clause : /on conflict/i conflict_algorigthm
 389
 390 conflict_algorigthm : /(rollback|abort|fail|ignore|replace)/i
 391
 392 parens_field_list : '(' column_list ')'
 393     { $item[2] }
 394
 395 column_list : field_name(s /,/)
 396
 397 parens_value_list : '(' VALUE(s /,/) ')'
 398     { $item[2] }
 399
 400 expr : /[^)]+/
 401
 402 sort_order : /(ASC|DESC)/i
 403
 404 #
 405 # Create Trigger
 406
 407 create : CREATE TEMPORARY(?) TRIGGER NAME before_or_after(?) database_event ON table_name trigger_action
 408     {
 409         my $table_name = $item[8]->{'name'};
 410         push @{ $tables{ $table_name }{'triggers'} }, {
 411             name         => $item[4],
 412             is_temporary => $item[2][0] ? 1 : 0,
 413             when         => $item[5][0],
 414             instead_of   => 0,
 415             db_event     => $item[6],
 416             action       => $item[9],
 417         }
 418     }
 419
 420 create : CREATE TEMPORARY(?) TRIGGER NAME instead_of database_event ON view_name trigger_action
 421     {
 422         my $table_name = $item[8]->{'name'};
 423         push @{ $tables{ $table_name }{'triggers'} }, {
 424             name         => $item[4],
 425             is_temporary => $item[2][0] ? 1 : 0,
 426             when         => undef,
 427             instead_of   => 1,
 428             db_event     => $item[6],
 429             action       => $item[9],
 430         }
 431     }
 432
 433 database_event : /(delete|insert|update)/i
 434
 435 database_event : /update of/i column_list
 436
 437 trigger_action : for_each(?) when(?) BEGIN_C trigger_step(s) END_C
 438     {
 439         $return = {
 440             for_each => $item[1][0],
 441             when     => $item[2][0],
 442             steps    => $item[4],
 443         }
 444     }
 445
 446 for_each : /FOR EACH ROW/i | /FOR EACH STATEMENT/i
 447
 448 when : WHEN expr { $item[2] }
 449
 450 trigger_step : /(select|delete|insert|update)/i /[^;]+/ SEMICOLON
 451     {
 452         $return = join( ' ', $item[1], $item[2] )
 453     }
 454
 455 before_or_after : /(before|after)/i { $return = lc $1 }
 456
 457 instead_of : /instead of/i
 458
 459 view_name : qualified_name
 460
 461 #
 462 # Tokens
 463 #
 464 BEGIN_C : /begin/i
 465
 466 END_C : /end/i
 467
 468 CREATE : /create/i
 469
 470 TEMPORARY : /temp(orary)?/i { 1 }
 471
 472 TABLE : /table/i
 473
 474 INDEX : /index/i
 475
 476 NOT_NULL : /not null/i
 477
 478 PRIMARY_KEY : /primary key/i
 479
 480 CHECK_C : /check/i
 481
 482 DEFAULT : /default/i
 483
 484 TRIGGER : /trigger/i
 485
 486 ON : /on/i
 487
 488 WORD : /\w+/
 489
 490 WHEN : /when/i
 491
 492 UNIQUE : /unique/i { 1 }
 493
 494 SEMICOLON : ';'
 495
 496 NAME    : /'?(\w+)'?/ { $return = $1 }
 497
 498 VALUE   : /[-+]?\.?\d+(?:[eE]\d+)?/
 499     { $item[1] }
 500     | /'.*?'/
 501     {
 502         # remove leading/trailing quotes
 503         my $val = $item[1];
 504         $val    =~ s/^['"]|['"]$//g;
 505         $return = $val;
 506     }
 507     | /NULL/
 508     { 'NULL' }
 509
 510 !;
 511
 512 # -------------------------------------------------------------------
 513 sub parse {
 514     my ( $translator, $data ) = @_;
 515     my $parser = Parse::RecDescent->new($GRAMMAR);
 516
 517     local $::RD_TRACE  = $translator->trace ? 1 : undef;
 518     local $DEBUG       = $translator->debug;
 519
 520     unless (defined $parser) {
 521         return $translator->error("Error instantiating Parse::RecDescent ".
 522             "instance: Bad grammer");
 523     }
 524
 525     my $result = $parser->startrule($data);
 526     return $translator->error( "Parse failed." ) unless defined $result;
 527     warn Dumper( $result ) if $DEBUG;
 528
 529     my $schema = $translator->schema;
 530     my @tables = sort {
 531         $result->{ $a }->{'order'} <=> $result->{ $b }->{'order'}
 532     } keys %{ $result };
 533
 534     for my $table_name ( @tables ) {
 535         my $tdata =  $result->{ $table_name };
 536         my $table =  $schema->add_table(
 537             name  => $tdata->{'name'},
 538         ) or die $schema->error;
 539
 540         $table->comments( $tdata->{'comments'} );
 541
 542         for my $fdata ( @{ $tdata->{'fields'} } ) {
 543             my $field = $table->add_field(
 544                 name              => $fdata->{'name'},
 545                 data_type         => $fdata->{'data_type'},
 546                 size              => $fdata->{'size'},
 547                 default_value     => $fdata->{'default'},
 548                 is_auto_increment => $fdata->{'is_auto_inc'},
 549                 is_nullable       => $fdata->{'is_nullable'},
 550                 comments          => $fdata->{'comments'},
 551             ) or die $table->error;
 552
 553             $table->primary_key( $field->name ) if $fdata->{'is_primary_key'};
 554
 555             for my $cdata ( @{ $fdata->{'constraints'} } ) {
 556                 next unless $cdata->{'type'} eq 'foreign_key';
 557                 $cdata->{'fields'} ||= [ $field->name ];
 558                 push @{ $tdata->{'constraints'} }, $cdata;
 559             }
 560         }
 561
 562         for my $idata ( @{ $tdata->{'indices'} || [] } ) {
 563             my $index  =  $table->add_index(
 564                 name   => $idata->{'name'},
 565                 type   => uc $idata->{'type'},
 566                 fields => $idata->{'fields'},
 567             ) or die $table->error;
 568         }
 569
 570         for my $cdata ( @{ $tdata->{'constraints'} || [] } ) {
 571             my $constraint       =  $table->add_constraint(
 572                 name             => $cdata->{'name'},
 573                 type             => $cdata->{'type'},
 574                 fields           => $cdata->{'fields'},
 575                 reference_table  => $cdata->{'reference_table'},
 576                 reference_fields => $cdata->{'reference_fields'},
 577                 match_type       => $cdata->{'match_type'} || '',
 578                 on_delete        => $cdata->{'on_delete_do'},
 579                 on_update        => $cdata->{'on_update_do'},
 580             ) or die $table->error;
 581         }
 582     }
 583
 584     return 1;
 585 }
 586
 587 1;
 588
 589 # -------------------------------------------------------------------
 590 # All wholsome food is caught without a net or a trap.
 591 # William Blake
 592 # -------------------------------------------------------------------
 593
 594 =pod
 595
 596 =head1 AUTHOR
 597
 598 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
 599
 600 =head1 SEE ALSO
 601
 602 perl(1), Parse::RecDescent, SQL::Translator::Schema.
 603
 604 =cut