lib/SQL/Translator/Parser/Access.pm

   1 package SQL::Translator::Parser::Access;
   2
   3 # -------------------------------------------------------------------
   4 # $Id$
   5 # -------------------------------------------------------------------
   6 # Copyright (C) 2002-2009 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::Access - parser for Access as produced by mdbtools
  26
  27 =head1 SYNOPSIS
  28
  29   use SQL::Translator;
  30   use SQL::Translator::Parser::Access;
  31
  32   my $translator = SQL::Translator->new;
  33   $translator->parser("SQL::Translator::Parser::Access");
  34
  35 =head1 DESCRIPTION
  36
  37 The grammar derived from the MySQL grammar.  The input is expected to be
  38 something similar to the output of mdbtools (http://mdbtools.sourceforge.net/).
  39
  40 =cut
  41
  42 use strict;
  43 use vars qw[ $DEBUG $GRAMMAR @EXPORT_OK ];
  44 $DEBUG   = 0 unless defined $DEBUG;
  45
  46 use Data::Dumper;
  47 use Parse::RecDescent;
  48 use Exporter;
  49 use base qw(Exporter);
  50
  51 @EXPORT_OK = qw(parse);
  52
  53 # Enable warnings within the Parse::RecDescent module.
  54 $::RD_ERRORS = 1; # Make sure the parser dies when it encounters an error
  55 $::RD_WARN   = 1; # Enable warnings. This will warn on unused rules &c.
  56 $::RD_HINT   = 1; # Give out hints to help fix problems.
  57
  58 $GRAMMAR = q!
  59
  60 {
  61     my ( %tables, $table_order, @table_comments );
  62 }
  63
  64 #
  65 # The "eofile" rule makes the parser fail if any "statement" rule
  66 # fails.  Otherwise, the first successful match by a "statement"
  67 # won't cause the failure needed to know that the parse, as a whole,
  68 # failed. -ky
  69 #
  70 startrule : statement(s) eofile { \%tables }
  71
  72 eofile : /^\Z/
  73
  74 statement : comment
  75     | use
  76     | set
  77     | drop
  78     | create
  79     | <error>
  80
  81 use : /use/i WORD ';'
  82     { @table_comments = () }
  83
  84 set : /set/i /[^;]+/ ';'
  85     { @table_comments = () }
  86
  87 drop : /drop/i TABLE /[^;]+/ ';'
  88
  89 drop : /drop/i WORD(s) ';'
  90     { @table_comments = () }
  91
  92 create : CREATE /database/i WORD ';'
  93     { @table_comments = () }
  94
  95 create : CREATE TABLE table_name '(' create_definition(s /,/) ')' ';'
  96     {
  97         my $table_name                       = $item{'table_name'};
  98         $tables{ $table_name }{'order'}      = ++$table_order;
  99         $tables{ $table_name }{'table_name'} = $table_name;
 100
 101         if ( @table_comments ) {
 102             $tables{ $table_name }{'comments'} = [ @table_comments ];
 103             @table_comments = ();
 104         }
 105
 106         my $i = 1;
 107         for my $definition ( @{ $item[5] } ) {
 108             if ( $definition->{'supertype'} eq 'field' ) {
 109                 my $field_name = $definition->{'name'};
 110                 $tables{ $table_name }{'fields'}{ $field_name } =
 111                     { %$definition, order => $i };
 112                 $i++;
 113
 114                 if ( $definition->{'is_primary_key'} ) {
 115                     push @{ $tables{ $table_name }{'constraints'} },
 116                         {
 117                             type   => 'primary_key',
 118                             fields => [ $field_name ],
 119                         }
 120                     ;
 121                 }
 122             }
 123             elsif ( $definition->{'supertype'} eq 'constraint' ) {
 124                 push @{ $tables{ $table_name }{'constraints'} }, $definition;
 125             }
 126             elsif ( $definition->{'supertype'} eq 'index' ) {
 127                 push @{ $tables{ $table_name }{'indices'} }, $definition;
 128             }
 129         }
 130
 131         1;
 132     }
 133
 134 create : CREATE UNIQUE(?) /(index|key)/i index_name /on/i table_name '(' field_name(s /,/) ')' ';'
 135     {
 136         @table_comments = ();
 137         push @{ $tables{ $item{'table_name'} }{'indices'} },
 138             {
 139                 name   => $item[4],
 140                 type   => $item[2] ? 'unique' : 'normal',
 141                 fields => $item[8],
 142             }
 143         ;
 144     }
 145
 146 create_definition : constraint
 147     | index
 148     | field
 149     | comment
 150     | <error>
 151
 152 comment : /^\s*--(.*)\n/
 153     {
 154         my $comment =  $1;
 155         $return     = $comment;
 156         push @table_comments, $comment;
 157     }
 158
 159 field : field_name data_type field_qualifier(s?) reference_definition(?)
 160     {
 161         $return = {
 162             supertype   => 'field',
 163             name        => $item{'field_name'},
 164             data_type   => $item{'data_type'}{'type'},
 165             size        => $item{'data_type'}{'size'},
 166             constraints => $item{'reference_definition(?)'},
 167         }
 168     }
 169     | <error>
 170
 171 field_qualifier : not_null
 172     {
 173         $return = {
 174              null => $item{'not_null'},
 175         }
 176     }
 177
 178 field_qualifier : default_val
 179     {
 180         $return = {
 181              default => $item{'default_val'},
 182         }
 183     }
 184
 185 field_qualifier : auto_inc
 186     {
 187         $return = {
 188              is_auto_inc => $item{'auto_inc'},
 189         }
 190     }
 191
 192 field_qualifier : primary_key
 193     {
 194         $return = {
 195              is_primary_key => $item{'primary_key'},
 196         }
 197     }
 198
 199 field_qualifier : unsigned
 200     {
 201         $return = {
 202              is_unsigned => $item{'unsigned'},
 203         }
 204     }
 205
 206 field_qualifier : /character set/i WORD
 207     {
 208         $return = {
 209             character_set => $item[2],
 210         }
 211     }
 212
 213 reference_definition : /references/i table_name parens_field_list(?) match_type(?) on_delete(?) on_update(?)
 214     {
 215         $return = {
 216             type             => 'foreign_key',
 217             reference_table  => $item[2],
 218             reference_fields => $item[3][0],
 219             match_type       => $item[4][0],
 220             on_delete        => $item[5][0],
 221             on_update        => $item[6][0],
 222         }
 223     }
 224
 225 match_type : /match full/i { 'full' }
 226     |
 227     /match partial/i { 'partial' }
 228
 229 on_delete : /on delete/i reference_option
 230     { $item[2] }
 231
 232 on_update : /on update/i reference_option
 233     { $item[2] }
 234
 235 reference_option: /restrict/i |
 236     /cascade/i   |
 237     /set null/i  |
 238     /no action/i |
 239     /set default/i
 240     { $item[1] }
 241
 242 index : normal_index
 243     | fulltext_index
 244     | <error>
 245
 246 table_name   : NAME
 247
 248 field_name   : NAME
 249
 250 index_name   : NAME
 251
 252 data_type    : access_data_type parens_value_list(s?) type_qualifier(s?)
 253     {
 254         $return        = {
 255             type       => $item[1],
 256             size       => $item[2][0],
 257             qualifiers => $item[3],
 258         }
 259     }
 260
 261 access_data_type : /long integer/i { $return = 'Long Integer' }
 262     | /text/i { $return = 'Text' }
 263     | /datetime (\(short\))?/i { $return = 'DateTime' }
 264     | /boolean/i { $return = 'Boolean' }
 265     | WORD
 266
 267 parens_field_list : '(' field_name(s /,/) ')'
 268     { $item[2] }
 269
 270 parens_value_list : '(' VALUE(s /,/) ')'
 271     { $item[2] }
 272
 273 type_qualifier : /(BINARY|UNSIGNED|ZEROFILL)/i
 274     { lc $item[1] }
 275
 276 field_type   : WORD
 277
 278 create_index : /create/i /index/i
 279
 280 not_null     : /not/i /null/i { $return = 0 }
 281
 282 unsigned     : /unsigned/i { $return = 0 }
 283
 284 default_val : /default/i /'(?:.*?\\')*.*?'|(?:')?[\w\d:.-]*(?:')?/
 285     {
 286         $item[2] =~ s/^\s*'|'\s*$//g;
 287         $return  =  $item[2];
 288     }
 289
 290 auto_inc : /auto_increment/i { 1 }
 291
 292 primary_key : /primary/i /key/i { 1 }
 293
 294 constraint : primary_key_def
 295     | unique_key_def
 296     | foreign_key_def
 297     | <error>
 298
 299 foreign_key_def : foreign_key_def_begin parens_field_list reference_definition
 300     {
 301         $return              =  {
 302             supertype        => 'constraint',
 303             type             => 'foreign_key',
 304             name             => $item[1],
 305             fields           => $item[2],
 306             %{ $item{'reference_definition'} },
 307         }
 308     }
 309
 310 foreign_key_def_begin : /constraint/i /foreign key/i
 311     { $return = '' }
 312     |
 313     /constraint/i WORD /foreign key/i
 314     { $return = $item[2] }
 315     |
 316     /foreign key/i
 317     { $return = '' }
 318
 319 primary_key_def : primary_key index_name(?) '(' name_with_opt_paren(s /,/) ')'
 320     {
 321         $return       = {
 322             supertype => 'constraint',
 323             name      => $item{'index_name(?)'}[0],
 324             type      => 'primary_key',
 325             fields    => $item[4],
 326         };
 327     }
 328
 329 unique_key_def : UNIQUE KEY(?) index_name(?) '(' name_with_opt_paren(s /,/) ')'
 330     {
 331         $return       = {
 332             supertype => 'constraint',
 333             name      => $item{'index_name(?)'}[0],
 334             type      => 'unique',
 335             fields    => $item[5],
 336         }
 337     }
 338
 339 normal_index : KEY index_name(?) '(' name_with_opt_paren(s /,/) ')'
 340     {
 341         $return       = {
 342             supertype => 'index',
 343             type      => 'normal',
 344             name      => $item{'index_name(?)'}[0],
 345             fields    => $item[4],
 346         }
 347     }
 348
 349 fulltext_index : /fulltext/i KEY(?) index_name(?) '(' name_with_opt_paren(s /,/) ')'
 350     {
 351         $return       = {
 352             supertype => 'index',
 353             type      => 'fulltext',
 354             name      => $item{'index_name(?)'}[0],
 355             fields    => $item[5],
 356         }
 357     }
 358
 359 name_with_opt_paren : NAME parens_value_list(s?)
 360     { $item[2][0] ? "$item[1]($item[2][0][0])" : $item[1] }
 361
 362 UNIQUE : /unique/i { 1 }
 363
 364 KEY : /key/i | /index/i
 365
 366 table_option : WORD /\s*=\s*/ WORD
 367     {
 368         $return = { $item[1] => $item[3] };
 369     }
 370
 371 CREATE : /create/i
 372
 373 TEMPORARY : /temporary/i
 374
 375 TABLE : /table/i
 376
 377 WORD : /\w+/
 378
 379 DIGITS : /\d+/
 380
 381 COMMA : ','
 382
 383 NAME    : "`" /\w+/ "`"
 384     { $item[2] }
 385     | /\w+/
 386     { $item[1] }
 387
 388 VALUE   : /[-+]?\.?\d+(?:[eE]\d+)?/
 389     { $item[1] }
 390     | /'.*?'/
 391     {
 392         # remove leading/trailing quotes
 393         my $val = $item[1];
 394         $val    =~ s/^['"]|['"]$//g;
 395         $return = $val;
 396     }
 397     | /NULL/
 398     { 'NULL' }
 399
 400 !;
 401
 402 # -------------------------------------------------------------------
 403 sub parse {
 404     my ( $translator, $data ) = @_;
 405     my $parser = Parse::RecDescent->new($GRAMMAR);
 406
 407     local $::RD_TRACE  = $translator->trace ? 1 : undef;
 408     local $DEBUG       = $translator->debug;
 409
 410     unless (defined $parser) {
 411         return $translator->error("Error instantiating Parse::RecDescent ".
 412             "instance: Bad grammer");
 413     }
 414
 415     my $result = $parser->startrule($data);
 416     return $translator->error( "Parse failed." ) unless defined $result;
 417     warn Dumper( $result ) if $DEBUG;
 418
 419     my $schema = $translator->schema;
 420     my @tables = sort {
 421         $result->{ $a }->{'order'} <=> $result->{ $b }->{'order'}
 422     } keys %{ $result };
 423
 424     for my $table_name ( @tables ) {
 425         my $tdata =  $result->{ $table_name };
 426         my $table =  $schema->add_table(
 427             name  => $tdata->{'table_name'},
 428         ) or die $schema->error;
 429
 430         $table->comments( $tdata->{'comments'} );
 431
 432         my @fields = sort {
 433             $tdata->{'fields'}->{$a}->{'order'}
 434             <=>
 435             $tdata->{'fields'}->{$b}->{'order'}
 436         } keys %{ $tdata->{'fields'} };
 437
 438         for my $fname ( @fields ) {
 439             my $fdata = $tdata->{'fields'}{ $fname };
 440             my $field = $table->add_field(
 441                 name              => $fdata->{'name'},
 442                 data_type         => $fdata->{'data_type'},
 443                 size              => $fdata->{'size'},
 444                 default_value     => $fdata->{'default'},
 445                 is_auto_increment => $fdata->{'is_auto_inc'},
 446                 is_nullable       => $fdata->{'null'},
 447                 comments          => $fdata->{'comments'},
 448             ) or die $table->error;
 449
 450             $table->primary_key( $field->name ) if $fdata->{'is_primary_key'};
 451         }
 452
 453         for my $idata ( @{ $tdata->{'indices'} || [] } ) {
 454             my $index  =  $table->add_index(
 455                 name   => $idata->{'name'},
 456                 type   => uc $idata->{'type'},
 457                 fields => $idata->{'fields'},
 458             ) or die $table->error;
 459         }
 460     }
 461
 462     return 1;
 463 }
 464
 465 1;
 466
 467 # -------------------------------------------------------------------
 468 # Where man is not nature is barren.
 469 # William Blake
 470 # -------------------------------------------------------------------
 471
 472 =pod
 473
 474 =head1 AUTHOR
 475
 476 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
 477
 478 =head1 SEE ALSO
 479
 480 perl(1), Parse::RecDescent, SQL::Translator::Schema.
 481
 482 =cut