lib/SQL/Translator/Parser/Access.pm

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